1 |
|
|
subroutine dates_demo |
2 |
|
|
! -------------------------------------------------------------- |
3 |
|
|
! |
4 |
|
|
! Conseils a l'utilisateur: |
5 |
|
|
! |
6 |
|
|
! 1. VOUS COMPILEZ LES ENTIERS EN 32 BITS: |
7 |
|
|
! Utilisez alors les routines |
8 |
|
|
! - ecartds: Ecart en secondes entre deux dates. |
9 |
|
|
! - ecartdj: Ecart en jours entre deux dates. |
10 |
|
|
! - dapluss: Date dans n secondes. |
11 |
|
|
! - daplusj: Date dans n jours. |
12 |
|
|
! - qqmmaa: Conversion d'un entier type AAAAQQMM vers une date en clair. |
13 |
|
|
! - ijoursem: Jour de la semaine de la date d'entree. |
14 |
|
|
! - quant: quantieme de l'annee d'une date donnee. |
15 |
|
|
! Ces routines sont compatibles avec des entiers 32 bits. |
16 |
|
|
! En effet elles appelent les routines citees ci-dessous, mais avec |
17 |
|
|
! les parametres subsequents assurant que seuls des entiers |
18 |
|
|
! representables en 32 bits y soient utilises. |
19 |
|
|
! |
20 |
|
|
! 2. VOUS COMPILEZ LES ENTIERS EN 64 BITS: |
21 |
|
|
! Vous pouvez alors utiliser toutes les routines ci-dessus |
22 |
|
|
! plus les suivantes, qui traitent des formats de dates |
23 |
|
|
! en entree/sortie en JOURS, HEURES, MINUTES ou SECONDES: |
24 |
|
|
! - ecartd: Ecart entre deux dates. |
25 |
|
|
! - gregod: Conversion Date > Ecart par rapport a une date fixe. |
26 |
|
|
! - gregoi: Conversion Ecart par rapport a une date fixe > Date. |
27 |
|
|
! - daplus: Quelle sera la date dans n jours (ou heures, etc...)? |
28 |
|
|
! - amqhms_vers_dj: Conversion date gr�gorienne (en 5 entiers et un r�el) > date julienne. |
29 |
|
|
! - dj_vers_amqhms: Conversion date julienne > date gr�gorienne (en 5 entiers et un r�el). |
30 |
|
|
! - amqhmsree_vers_dj: Conversion date gr�gorienne (en un seul r�el) > date julienne. |
31 |
|
|
! - dj_vers_amqhmsree: Conversion date julienne > date gr�gorienne (en un seul r�el). |
32 |
|
|
! |
33 |
|
|
! -------------------------------------------------------------- |
34 |
|
|
! |
35 |
|
|
! D�finition des dates employ�es ci-dessous: |
36 |
|
|
! |
37 |
|
|
! Date julienne DJ: |
38 |
|
|
! Elle est compos�e d'un r�el. |
39 |
|
|
! R1: Ce r�el cro�t de 1 tous les jours, |
40 |
|
|
! et vaut 2451545.0 le 1er janvier 2000 � 12 UTC. |
41 |
|
|
! |
42 |
|
|
! Date gr�gorienne "en clair" AMQHMS: |
43 |
|
|
! Elle est compos�e de 5 entiers et d'un r�el. |
44 |
|
|
! E1: Ann�e (4 chiffres!) |
45 |
|
|
! E2: Mois |
46 |
|
|
! E3: Jour |
47 |
|
|
! E4: Heure |
48 |
|
|
! E5: Minute |
49 |
|
|
! R1: Seconde |
50 |
|
|
! -------------------------------------------------------------- |
51 |
|
|
|
52 |
|
|
|
53 |
|
|
IMPLICIT NONE |
54 |
|
|
end |
55 |
|
|
subroutine date_plus_ech(kan,kmo,kqu,psssss,pstati,cdtit) |
56 |
|
|
! -------------------------------------------------------------- |
57 |
|
|
! Ecriture en clair d'une date de type BASE 2000.01.15 00:00 +72H VALID 2000.01.18 15:00. |
58 |
|
|
! -------------------------------------------------------------- |
59 |
|
|
! Sujet: |
60 |
|
|
! Arguments explicites: |
61 |
|
|
! Arguments implicites: |
62 |
|
|
! Methode: |
63 |
|
|
! Externes: |
64 |
|
|
! Auteur: 2000-09, J.M. Piriou. |
65 |
|
|
! Modifications: |
66 |
|
|
! -------------------------------------------------------------- |
67 |
|
|
! En entree: |
68 |
|
|
! kan,kmo,kqu,psssss,pstati |
69 |
|
|
! En sortie: |
70 |
|
|
! cdtit |
71 |
|
|
! -------------------------------------------------------------- |
72 |
|
|
|
73 |
|
|
|
74 |
|
|
IMPLICIT NONE |
75 |
|
|
INTEGER(KIND=4) :: kan,kmo,kqu,ihe,imi,imiv,ihev,iquv,imov,ianv,ilze |
76 |
|
|
REAL(KIND=8) :: psssss,pstati |
77 |
|
|
REAL(KIND=8) :: zs |
78 |
|
|
REAL(KIND=8) :: zsssss,zdj,zsv |
79 |
|
|
REAL(KIND=8) :: zech |
80 |
|
|
character*200 clzue,clze,clech |
81 |
|
|
character *(*) cdtit |
82 |
|
|
! |
83 |
|
|
!------------------------------------------------- |
84 |
|
|
! Date de validit�. |
85 |
|
|
!------------------------------------------------- |
86 |
|
|
! |
87 |
|
|
zs=0. |
88 |
|
|
zsssss=psssss/3600. |
89 |
|
|
ihe=int(zsssss) ! heure de la base. |
90 |
|
|
zsssss=(zsssss-real(ihe))*60. |
91 |
|
|
imi=int(zsssss) ! minute de la base. |
92 |
|
|
zsssss=zsssss-real(imi) |
93 |
|
|
call amqhms_vers_dj(kan,kmo,kqu,ihe,imi,zs,zdj) |
94 |
|
|
zdj=zdj+pstati/86400. ! date julienne de validit�. |
95 |
|
|
call dj_vers_amqhms(zdj,ianv,imov,iquv,ihev,imiv,zsv) ! date gr�gorienne de validit�. |
96 |
|
|
if(pstati < 3600.) then |
97 |
|
|
! |
98 |
|
|
!------------------------------------------------- |
99 |
|
|
! Ech�ance en minutes. |
100 |
|
|
!------------------------------------------------- |
101 |
|
|
! |
102 |
|
|
zech=pstati/60. ; clzue='mn' |
103 |
|
|
elseif(pstati < 259200.) then |
104 |
|
|
! |
105 |
|
|
!------------------------------------------------- |
106 |
|
|
! Ech�ance en heures. |
107 |
|
|
!------------------------------------------------- |
108 |
|
|
! |
109 |
|
|
zech=pstati/3600. ; clzue='h' |
110 |
|
|
else |
111 |
|
|
! |
112 |
|
|
!------------------------------------------------- |
113 |
|
|
! Ech�ance en jours. |
114 |
|
|
!------------------------------------------------- |
115 |
|
|
! |
116 |
|
|
zech=pstati/86400. ; clzue='j' |
117 |
|
|
endif |
118 |
|
|
! |
119 |
|
|
! Affichage de l'echeance avec deux chiffres apres la virgule. |
120 |
|
|
! |
121 |
|
|
write(clze,fmt='(f9.2)') zech |
122 |
|
|
! |
123 |
|
|
! Si l'echeance est voisine d'un entier a mieux que 10**-2 pres, |
124 |
|
|
! on l'affiche au format entier. |
125 |
|
|
! |
126 |
|
|
if(clze(len_trim(clze)-2:len_trim(clze)) == '.00') then |
127 |
|
|
clze=clze(1:len_trim(clze)-3) |
128 |
|
|
endif |
129 |
|
|
clze=adjustl(clze) |
130 |
|
|
ilze=len_trim(clze) |
131 |
|
|
clech=clze(1:ilze)//clzue |
132 |
|
|
! |
133 |
|
|
!------------------------------------------------- |
134 |
|
|
! Titre 3, de type |
135 |
|
|
! BASE 2000.01.15 00:00 +72H VALID 2000.01.18 15:00. |
136 |
|
|
!------------------------------------------------- |
137 |
|
|
! |
138 |
|
|
if(imi == 0 .and. imiv == 0) then |
139 |
|
|
! |
140 |
|
|
!------------------------------------------------- |
141 |
|
|
! Les minutes de base et validit� sont nulles. |
142 |
|
|
! On ne les affiche pas. |
143 |
|
|
!------------------------------------------------- |
144 |
|
|
! |
145 |
|
|
write(cdtit,fmt='(a,i2,a,i2.2,a,i4.4,a,i2.2,3a,i2,a,i2.2,a,i4.4,a,i2.2,a)')& |
146 |
|
|
&'BASE ',kqu,'.',kmo,'.',kan,' ',ihe,'h UTC + ',clech(1:len_trim(clech))& |
147 |
|
|
&,', VALID ',iquv,'.',imov,'.',ianv,' ',ihev,'h UTC' |
148 |
|
|
else |
149 |
|
|
! |
150 |
|
|
!------------------------------------------------- |
151 |
|
|
! Les minutes de base ou validit� sont non nulles. |
152 |
|
|
! On les affiche. |
153 |
|
|
!------------------------------------------------- |
154 |
|
|
! |
155 |
|
|
write(cdtit,fmt='(a,i2,a,i2.2,a,i4.4,a,i2.2,a,i2.2,3a,i2,a,i2.2,a,i4.4,a,i2.2,a,i2.2,a)')& |
156 |
|
|
&'BASE ',kqu,'.',kmo,'.',kan,' ',ihe,':',imi,' UTC + ',clech(1:len_trim(clech))& |
157 |
|
|
&,' VALID ',iquv,'.',imov,'.',ianv,' ',ihev,':',imiv,' UTC' |
158 |
|
|
endif |
159 |
|
|
end |
160 |
|
|
subroutine datc(kaaaa,kmm,kqq,khh,kmi,kss,kjs,cdjs,cddt) |
161 |
|
|
! -------------------------------------------------------------- |
162 |
|
|
! **** *datc* Date courante machine. |
163 |
|
|
! -------------------------------------------------------------- |
164 |
|
|
! Sujet: |
165 |
|
|
! ------ |
166 |
|
|
! Arguments explicites: |
167 |
|
|
! --------------------- |
168 |
|
|
! Arguments implicites: |
169 |
|
|
! --------------------- |
170 |
|
|
! Methode: |
171 |
|
|
! -------- |
172 |
|
|
! Externes: |
173 |
|
|
! --------- |
174 |
|
|
! Auteur: 95-05, J.M. Piriou. |
175 |
|
|
! ------- |
176 |
|
|
! Modifications: |
177 |
|
|
! -------------------------------------------------------------- |
178 |
|
|
! En entree: |
179 |
|
|
! En sortie: |
180 |
|
|
! kaaaa annee. |
181 |
|
|
! kmm mois. |
182 |
|
|
! kqq quantieme. |
183 |
|
|
! khh heure. |
184 |
|
|
! kmi minute. |
185 |
|
|
! kss seconde. |
186 |
|
|
! kjs jour de la semaine (0: dimanche, 6 samedi). |
187 |
|
|
! cdjs jour de la semaine sur 3 caracteres (Dim, Lun, etc...). |
188 |
|
|
! cddt date totale (19950301-Mer-16:56:32). |
189 |
|
|
! -------------------------------------------------------------- |
190 |
|
|
|
191 |
|
|
|
192 |
|
|
IMPLICIT NONE |
193 |
|
|
INTEGER(KIND=4) :: idatat(8) |
194 |
|
|
INTEGER(KIND=4) :: kjs |
195 |
|
|
INTEGER(KIND=4) :: kss |
196 |
|
|
INTEGER(KIND=4) :: kmi |
197 |
|
|
INTEGER(KIND=4) :: khh |
198 |
|
|
INTEGER(KIND=4) :: kqq |
199 |
|
|
INTEGER(KIND=4) :: kmm |
200 |
|
|
INTEGER(KIND=4) :: kaaaa |
201 |
|
|
INTEGER(KIND=4) :: iaaaammqq |
202 |
|
|
INTEGER(KIND=4) :: ijoursem |
203 |
|
|
REAL(KIND=8) :: zs |
204 |
|
|
character*200 clgol1,clgol2,clgol3 |
205 |
|
|
character*3 cdjs |
206 |
|
|
character*(*) cddt |
207 |
|
|
character*3 cljour(0:6) |
208 |
|
|
data cljour/'Dim','Lun','Mar','Mer','Jeu','Ven','Sam'/ |
209 |
|
|
! |
210 |
|
|
!------------------------------------------------- |
211 |
|
|
! Date courante � la f90. |
212 |
|
|
!------------------------------------------------- |
213 |
|
|
! |
214 |
|
|
clgol1=' ' |
215 |
|
|
clgol2=' ' |
216 |
|
|
clgol3=' ' |
217 |
|
|
call date_and_time(clgol1,clgol2,clgol3,idatat) |
218 |
|
|
! |
219 |
|
|
!------------------------------------------------- |
220 |
|
|
! clgol1 est du type "AAAAMMQQ". |
221 |
|
|
!------------------------------------------------- |
222 |
|
|
! |
223 |
|
|
read(clgol1,fmt='(i4,2i2)') kaaaa,kmm,kqq |
224 |
|
|
! |
225 |
|
|
!------------------------------------------------- |
226 |
|
|
! clgol2 est du type "HHMMSS.SSS". |
227 |
|
|
!------------------------------------------------- |
228 |
|
|
! |
229 |
|
|
read(clgol2,fmt='(2i2)') khh,kmi |
230 |
|
|
read(clgol2(5:),fmt=*) zs |
231 |
|
|
kss=nint(zs) |
232 |
|
|
read(clgol1,fmt='(i8)') iaaaammqq |
233 |
|
|
! |
234 |
|
|
!------------------------------------------------- |
235 |
|
|
! Jour de la semaine. |
236 |
|
|
!------------------------------------------------- |
237 |
|
|
! |
238 |
|
|
kjs=ijoursem(iaaaammqq) |
239 |
|
|
cdjs=cljour(kjs) |
240 |
|
|
! |
241 |
|
|
!------------------------------------------------- |
242 |
|
|
! Date totale. |
243 |
|
|
!------------------------------------------------- |
244 |
|
|
! |
245 |
|
|
write(cddt,fmt='(i4.4,a,2(i2.2,a),2a,i2.2,a,i2.2,a,i2.2)') & |
246 |
|
|
&kaaaa,'_',kmm,'_',kqq,'_',cdjs,'_',khh,':',kmi,':',kss |
247 |
|
|
end |
248 |
|
|
subroutine amqhms_vers_dj(kaaaa,kmm,kqq,khh,kmn,ps,pdj) |
249 |
|
|
! -------------------------------------------------------------------------- |
250 |
|
|
! **** *amqhms_vers_dj* |
251 |
|
|
! -------------------------------------------------------------------------- |
252 |
|
|
! Auteur: |
253 |
|
|
! ------- |
254 |
|
|
! 1999-08-17, J.M. Piriou. |
255 |
|
|
! |
256 |
|
|
! Modifications: |
257 |
|
|
! -------------- |
258 |
|
|
! |
259 |
|
|
! -------------------------------------------------------------------------- |
260 |
|
|
! En entree: |
261 |
|
|
! kaaaa ann�e (4 chiffres!) |
262 |
|
|
! kmm mois |
263 |
|
|
! kqq quanti�me du mois |
264 |
|
|
! khh heure |
265 |
|
|
! kmn minute |
266 |
|
|
! ps seconde |
267 |
|
|
! En sortie: |
268 |
|
|
! pdj date julienne associ�e � la date gr�gorienne UTC d'entr�e |
269 |
|
|
! -------------------------------------------------------------------------- |
270 |
|
|
|
271 |
|
|
|
272 |
|
|
IMPLICIT NONE |
273 |
|
|
INTEGER(KIND=4) :: IDATE1 |
274 |
|
|
INTEGER(KIND=4) :: IDATE2 |
275 |
|
|
INTEGER(KIND=4) :: IECART |
276 |
|
|
INTEGER(KIND=4) :: KAAAA |
277 |
|
|
INTEGER(KIND=4) :: KHH |
278 |
|
|
INTEGER(KIND=4) :: KMM |
279 |
|
|
INTEGER(KIND=4) :: KMN |
280 |
|
|
INTEGER(KIND=4) :: KQQ |
281 |
|
|
REAL(KIND=8) :: PDJ |
282 |
|
|
REAL(KIND=8) :: PS |
283 |
|
|
|
284 |
|
|
idate1=20000101 |
285 |
|
|
idate2=kaaaa*10000+kmm*100+kqq |
286 |
|
|
! |
287 |
|
|
!------------------------------------------------- |
288 |
|
|
! Nombre de jours �coul�s entre la date |
289 |
|
|
! d'entr�e � 0h UTC et le 1er janvier 2000 � 0h UTC. |
290 |
|
|
!------------------------------------------------- |
291 |
|
|
! |
292 |
|
|
call ecartdj(idate1,idate2,iecart) |
293 |
|
|
! |
294 |
|
|
!------------------------------------------------- |
295 |
|
|
! Date julienne. |
296 |
|
|
!------------------------------------------------- |
297 |
|
|
! |
298 |
|
|
pdj=2451545.0- 0.5 +real(iecart)+real(khh)/24. & |
299 |
|
|
& +real(kmn)/1440.+ps/86400. |
300 |
|
|
end |
301 |
|
|
subroutine daplus(kdat1,kopt,kdelt,kdat2) |
302 |
|
|
! -------------------------------------------------------------------------- |
303 |
|
|
! **** *DAPLUS* Quelle sera la date dans n jours (ou heures, etc...)? |
304 |
|
|
! -------------------------------------------------------------------------- |
305 |
|
|
! Auteur: |
306 |
|
|
! ------- |
307 |
|
|
! 94-10-31, J.M. Piriou. |
308 |
|
|
! |
309 |
|
|
! Modifications: |
310 |
|
|
! -------------- |
311 |
|
|
! |
312 |
|
|
! -------------------------------------------------------------------------- |
313 |
|
|
! En entree: |
314 |
|
|
! kdat1 |
315 |
|
|
! kopt option de precision sur les dates: |
316 |
|
|
! 1 : au jour pres |
317 |
|
|
! 2 : a l'heure pres |
318 |
|
|
! 3 : a la minute pres |
319 |
|
|
! 4 : a la seconde pres |
320 |
|
|
! - si kopt=1 : kdat au format AAAAMMQQ |
321 |
|
|
! - si kopt=2 : kdat au format AAAAMMQQHH |
322 |
|
|
! - si kopt=3 : kdat au format AAAAMMQQHHMM |
323 |
|
|
! - si kopt=4 : kdat au format AAAAMMQQHHMMSS |
324 |
|
|
! (cf. GREGOD). |
325 |
|
|
! kdelt duree a ajouter a kdat1, unite: celle imposee par kopt. |
326 |
|
|
! En sortie: |
327 |
|
|
! kdat2 date finale. |
328 |
|
|
! |
329 |
|
|
! -------------------------------------------------------------------------- |
330 |
|
|
! Exemple: call DAPLUS(19940503,1,456,ires) fournira |
331 |
|
|
! dans ires la date au format AAAAMMQQ situee 456 jours apres |
332 |
|
|
! le 3 mai 1994. |
333 |
|
|
! -------------------------------------------------------------------------- |
334 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
335 |
|
|
! ATTENTION A LA PRECISION: |
336 |
|
|
! 1. Vous compilez les entiers sur 32 bits: |
337 |
|
|
! Vous devez alors vous limiter a kopt <= 2. |
338 |
|
|
! 2. Vous compilez les entiers sur 64 bits: |
339 |
|
|
! Vous pouvez utiliser toutes les valeurs de kopt. |
340 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
341 |
|
|
|
342 |
|
|
|
343 |
|
|
IMPLICIT NONE |
344 |
|
|
INTEGER(KIND=4) :: IGRE |
345 |
|
|
INTEGER(KIND=4) :: KDAT1 |
346 |
|
|
INTEGER(KIND=4) :: KDAT2 |
347 |
|
|
INTEGER(KIND=4) :: KDELT |
348 |
|
|
INTEGER(KIND=4) :: KOPT |
349 |
|
|
call gregod(kdat1,kopt,igre) |
350 |
|
|
igre=igre+kdelt |
351 |
|
|
call gregoi(igre,kopt,kdat2) |
352 |
|
|
end |
353 |
|
|
subroutine daplusj(k1,kec,k2) |
354 |
|
|
! -------------------------------------------------------------- |
355 |
|
|
! **** *daplusj* Date dans n jours. |
356 |
|
|
! -------------------------------------------------------------- |
357 |
|
|
! Sujet: |
358 |
|
|
! Arguments explicites: |
359 |
|
|
! Arguments implicites: |
360 |
|
|
! Methode: |
361 |
|
|
! Externes: |
362 |
|
|
! Auteur: 97-11, J.M. Piriou. |
363 |
|
|
! Modifications: |
364 |
|
|
! -------------------------------------------------------------- |
365 |
|
|
! En entree: |
366 |
|
|
! k1 date de depart au format AAAAMMQQ. |
367 |
|
|
! kec nombre de jours ecoules. |
368 |
|
|
! En sortie: |
369 |
|
|
! k2 date d'arrivee au format AAAAMMQQ. |
370 |
|
|
! -------------------------------------------------------------- |
371 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
372 |
|
|
! PRECISION: |
373 |
|
|
! Cette routine est utilisable avec des entiers 32 bits ou 64 bits. |
374 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
375 |
|
|
! |
376 |
|
|
! ------------------------------------------------- |
377 |
|
|
! Date d'arrivee au jour pres. |
378 |
|
|
! ------------------------------------------------- |
379 |
|
|
! |
380 |
|
|
|
381 |
|
|
|
382 |
|
|
IMPLICIT NONE |
383 |
|
|
INTEGER(KIND=4) :: K1 |
384 |
|
|
INTEGER(KIND=4) :: K2 |
385 |
|
|
INTEGER(KIND=4) :: KEC |
386 |
|
|
call daplus(k1,1,kec,k2) |
387 |
|
|
end |
388 |
|
|
subroutine dapluss(cd1,kec,cd2) |
389 |
|
|
! -------------------------------------------------------------- |
390 |
|
|
! **** *dapluss* Date dans n secondes. |
391 |
|
|
! -------------------------------------------------------------- |
392 |
|
|
! Sujet: |
393 |
|
|
! Arguments explicites: |
394 |
|
|
! Arguments implicites: |
395 |
|
|
! Methode: |
396 |
|
|
! Externes: |
397 |
|
|
! Auteur: 97-11, J.M. Piriou. |
398 |
|
|
! Modifications: |
399 |
|
|
! -------------------------------------------------------------- |
400 |
|
|
! En entree: |
401 |
|
|
! cd1 date de depart au format 'AAAAMMQQHHNNSS'. |
402 |
|
|
! kec nombre de secondes ecoulees. |
403 |
|
|
! En sortie: |
404 |
|
|
! cd2 date d'arrivee au format 'AAAAMMQQHHNNSS'. |
405 |
|
|
! -------------------------------------------------------------- |
406 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
407 |
|
|
! ATTENTION A LA PRECISION: |
408 |
|
|
! Cette routine est utilisable avec des entiers 32 bits, |
409 |
|
|
! si l'ecart entre les deux dates est inferieur a 2**31 secondes, |
410 |
|
|
! soit 68 ans!... |
411 |
|
|
! |
412 |
|
|
! Au-dela de cette duree, les entiers doivent etre 64 bits. |
413 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
414 |
|
|
|
415 |
|
|
|
416 |
|
|
IMPLICIT NONE |
417 |
|
|
INTEGER(KIND=4) :: IAMQ1 |
418 |
|
|
INTEGER(KIND=4) :: IAMQ2 |
419 |
|
|
INTEGER(KIND=4) :: IDELTA |
420 |
|
|
INTEGER(KIND=4) :: IECJOURS |
421 |
|
|
INTEGER(KIND=4) :: IH1 |
422 |
|
|
INTEGER(KIND=4) :: IH2 |
423 |
|
|
INTEGER(KIND=4) :: IM1 |
424 |
|
|
INTEGER(KIND=4) :: IM2 |
425 |
|
|
INTEGER(KIND=4) :: IRESTE |
426 |
|
|
INTEGER(KIND=4) :: IS1 |
427 |
|
|
INTEGER(KIND=4) :: IS2 |
428 |
|
|
INTEGER(KIND=4) :: ISEC |
429 |
|
|
INTEGER(KIND=4) :: KEC |
430 |
|
|
character*(*) cd1,cd2 |
431 |
|
|
! |
432 |
|
|
! ------------------------------------------------- |
433 |
|
|
! On lit les dates sur des entiers. |
434 |
|
|
! ------------------------------------------------- |
435 |
|
|
! |
436 |
|
|
read(cd1,fmt='(i8,3i2)') iamq1,ih1,im1,is1 |
437 |
|
|
! |
438 |
|
|
! ------------------------------------------------- |
439 |
|
|
! Calculs d'ecarts et de leur partition |
440 |
|
|
! en multiples de 86400 et sous-multiples. |
441 |
|
|
! ------------------------------------------------- |
442 |
|
|
! |
443 |
|
|
isec=ih1*3600+im1*60+is1 ! nombre de secondes ecoulees depuis cd10h. |
444 |
|
|
idelta=kec+isec ! nombre de secondes entre cd10h et cd2. |
445 |
|
|
ireste=modulo(idelta,86400) ! nombre de secondes entre cd20h et cd2. |
446 |
|
|
iecjours=(idelta-ireste)/86400 ! nombre de jours entre cd10h et cd20h. |
447 |
|
|
! |
448 |
|
|
! ------------------------------------------------- |
449 |
|
|
! Date d'arrivee au jour pres. |
450 |
|
|
! ------------------------------------------------- |
451 |
|
|
! |
452 |
|
|
call daplus(iamq1,1,iecjours,iamq2) |
453 |
|
|
! |
454 |
|
|
! ------------------------------------------------- |
455 |
|
|
! Date finale a la seconde pres. |
456 |
|
|
! ------------------------------------------------- |
457 |
|
|
! |
458 |
|
|
ih2=ireste/3600 |
459 |
|
|
ireste=ireste-3600*ih2 |
460 |
|
|
im2=ireste/60 |
461 |
|
|
ireste=ireste-60*im2 |
462 |
|
|
is2=ireste |
463 |
|
|
write(cd2,fmt='(i8,3i2.2)') iamq2,ih2,im2,is2 |
464 |
|
|
end |
465 |
|
|
subroutine dj_vers_amqhms(pdj,kaaaa,kmm,kqq,khh,kmn,ps) |
466 |
|
|
! -------------------------------------------------------------------------- |
467 |
|
|
! **** *dj_vers_amqhms* |
468 |
|
|
! -------------------------------------------------------------------------- |
469 |
|
|
! Auteur: |
470 |
|
|
! ------- |
471 |
|
|
! 1999-08-17, J.M. Piriou. |
472 |
|
|
! |
473 |
|
|
! Modifications: |
474 |
|
|
! -------------- |
475 |
|
|
! |
476 |
|
|
! -------------------------------------------------------------------------- |
477 |
|
|
! En entree: |
478 |
|
|
! pdj date julienne associ�e � la date gr�gorienne UTC d'entr�e |
479 |
|
|
! En sortie: |
480 |
|
|
! kaaaa ann�e (4 chiffres!) |
481 |
|
|
! kmm mois |
482 |
|
|
! kqq quanti�me du mois |
483 |
|
|
! khh heure |
484 |
|
|
! kmn minute |
485 |
|
|
! ps seconde |
486 |
|
|
! -------------------------------------------------------------------------- |
487 |
|
|
! |
488 |
|
|
!------------------------------------------------- |
489 |
|
|
! Nombre de jours entre le 1er janvier 2000 � 0 UTC |
490 |
|
|
! et la date julienne courante. |
491 |
|
|
!------------------------------------------------- |
492 |
|
|
! |
493 |
|
|
|
494 |
|
|
|
495 |
|
|
IMPLICIT NONE |
496 |
|
|
INTEGER(KIND=4) :: IDATE1 |
497 |
|
|
INTEGER(KIND=4) :: IDATE2 |
498 |
|
|
INTEGER(KIND=4) :: IECART |
499 |
|
|
INTEGER(KIND=4) :: KAAAA |
500 |
|
|
INTEGER(KIND=4) :: KHH |
501 |
|
|
INTEGER(KIND=4) :: KMM |
502 |
|
|
INTEGER(KIND=4) :: KMN |
503 |
|
|
INTEGER(KIND=4) :: KNOUV |
504 |
|
|
INTEGER(KIND=4) :: KQQ |
505 |
|
|
REAL(KIND=8) :: PDJ |
506 |
|
|
REAL(KIND=8) :: PS |
507 |
|
|
REAL(KIND=8) :: ZECART |
508 |
|
|
REAL(KIND=8) :: ZFRAC |
509 |
|
|
zecart=pdj-2451544.5 |
510 |
|
|
! |
511 |
|
|
!------------------------------------------------- |
512 |
|
|
! Nombre entier de jours. |
513 |
|
|
!------------------------------------------------- |
514 |
|
|
! |
515 |
|
|
zfrac=modulo(zecart, 1._8 ) |
516 |
|
|
iecart=nint(zecart-zfrac) |
517 |
|
|
! |
518 |
|
|
!------------------------------------------------- |
519 |
|
|
! Date gr�gorienne associ�e. |
520 |
|
|
!------------------------------------------------- |
521 |
|
|
! |
522 |
|
|
idate1=20000101 |
523 |
|
|
call daplusj(idate1,iecart,idate2) |
524 |
|
|
kqq=mod(idate2,100) |
525 |
|
|
knouv=idate2/100 |
526 |
|
|
kmm=mod(knouv,100) |
527 |
|
|
kaaaa=knouv/100 |
528 |
|
|
! |
529 |
|
|
!------------------------------------------------- |
530 |
|
|
! Calcul de des heure, minute et seconde. |
531 |
|
|
!------------------------------------------------- |
532 |
|
|
! |
533 |
|
|
zfrac=(zecart-real(iecart))*24. |
534 |
|
|
khh=int(zfrac) |
535 |
|
|
zfrac=(zfrac-real(khh))*60. |
536 |
|
|
kmn=int(zfrac) |
537 |
|
|
ps=(zfrac-real(kmn))*60. |
538 |
|
|
end |
539 |
|
|
subroutine dj_vers_amqhmsree(pdj,pgrer) |
540 |
|
|
! -------------------------------------------------------------------------- |
541 |
|
|
! **** ** |
542 |
|
|
! -------------------------------------------------------------------------- |
543 |
|
|
! Auteur: |
544 |
|
|
! ------- |
545 |
|
|
! 2002-11, J.M. Piriou. |
546 |
|
|
! |
547 |
|
|
! Modifications: |
548 |
|
|
! -------------- |
549 |
|
|
! |
550 |
|
|
! -------------------------------------------------------------------------- |
551 |
|
|
! En entree: |
552 |
|
|
! pdj date julienne |
553 |
|
|
! En sortie: |
554 |
|
|
! pgrer date en clair au format AAAAMMQQ.HHMMSS |
555 |
|
|
! -------------------------------------------------------------------------- |
556 |
|
|
! |
557 |
|
|
|
558 |
|
|
IMPLICIT NONE |
559 |
|
|
REAL(KIND=8), intent(in) :: PDJ |
560 |
|
|
REAL(KIND=8), intent(out) :: pgrer |
561 |
|
|
REAL(KIND=8) :: ZS |
562 |
|
|
INTEGER(KIND=4) :: iaaaa,imm,iqq,ihh,imn |
563 |
|
|
! |
564 |
|
|
!------------------------------------------------- |
565 |
|
|
! Conversion gr�gorien julien; cible 5 entiers et un r�el. |
566 |
|
|
!------------------------------------------------- |
567 |
|
|
! |
568 |
|
|
call dj_vers_amqhms(pdj,iaaaa,imm,iqq,ihh,imn,zs) |
569 |
|
|
! |
570 |
|
|
!------------------------------------------------- |
571 |
|
|
! On passe de ces 5 entiers et un r�el � un seul r�el. |
572 |
|
|
!------------------------------------------------- |
573 |
|
|
! |
574 |
|
|
pgrer=real(iaaaa)*10000.+real(imm)*100. & |
575 |
|
|
& + real(iqq)+real(ihh)/100. & |
576 |
|
|
& + real(imn)/10000.+zs/1.E+06 |
577 |
|
|
end |
578 |
|
|
subroutine amqhmsree_vers_dj(pgrer,pdj) |
579 |
|
|
! -------------------------------------------------------------------------- |
580 |
|
|
! **** ** |
581 |
|
|
! -------------------------------------------------------------------------- |
582 |
|
|
! Auteur: |
583 |
|
|
! ------- |
584 |
|
|
! 2002-11, J.M. Piriou. |
585 |
|
|
! |
586 |
|
|
! Modifications: |
587 |
|
|
! -------------- |
588 |
|
|
! |
589 |
|
|
! -------------------------------------------------------------------------- |
590 |
|
|
! En entree: |
591 |
|
|
! pgrer date en clair au format AAAAMMQQ.HHMMSS |
592 |
|
|
! En sortie: |
593 |
|
|
! pdj date julienne associ�e � la date gr�gorienne |
594 |
|
|
! -------------------------------------------------------------------------- |
595 |
|
|
! |
596 |
|
|
|
597 |
|
|
IMPLICIT NONE |
598 |
|
|
REAL(KIND=8), intent(out) :: PDJ |
599 |
|
|
REAL(KIND=8), intent(in) :: pgrer |
600 |
|
|
REAL(KIND=8) :: ZS,zloc |
601 |
|
|
INTEGER(KIND=4) :: iaaaa,imm,iqq,ihh,imn,iloc |
602 |
|
|
! |
603 |
|
|
!------------------------------------------------- |
604 |
|
|
! On passe de cette date gr�gorienne donn�e |
605 |
|
|
! comme un seul r�el � 5 entiers et un r�el. |
606 |
|
|
!------------------------------------------------- |
607 |
|
|
! |
608 |
|
|
iloc=int(pgrer) |
609 |
|
|
iqq=mod(iloc,100) |
610 |
|
|
iloc=iloc/100 |
611 |
|
|
imm=mod(iloc,100) |
612 |
|
|
iaaaa=iloc/100 |
613 |
|
|
|
614 |
|
|
iloc=nint((pgrer-real(int(pgrer)))*1.E+06) |
615 |
|
|
zs=real(mod(iloc,100)) |
616 |
|
|
iloc=iloc/100 |
617 |
|
|
imn=mod(iloc,100) |
618 |
|
|
ihh=iloc/100 |
619 |
|
|
! |
620 |
|
|
!------------------------------------------------- |
621 |
|
|
! Conversion gr�gorien julien; cible 5 entiers et un r�el. |
622 |
|
|
!------------------------------------------------- |
623 |
|
|
! |
624 |
|
|
call amqhms_vers_dj(iaaaa,imm,iqq,ihh,imn,zs,pdj) |
625 |
|
|
end |
626 |
|
|
subroutine ecartd(kdat1,kdat2,kopt,kgre) |
627 |
|
|
! -------------------------------------------------------------------------- |
628 |
|
|
! **** *ECART* Ecart entre deux dates. |
629 |
|
|
! -------------------------------------------------------------------------- |
630 |
|
|
! Auteur: |
631 |
|
|
! ------- |
632 |
|
|
! 97-01-09, J.M. Piriou. |
633 |
|
|
! |
634 |
|
|
! Modifications: |
635 |
|
|
! -------------- |
636 |
|
|
! |
637 |
|
|
! -------------------------------------------------------------------------- |
638 |
|
|
! En entree: kopt option de precision sur les dates: |
639 |
|
|
! 1 : au jour pres |
640 |
|
|
! 2 : a l'heure pres |
641 |
|
|
! 3 : a la minute pres |
642 |
|
|
! 4 : a la seconde pres |
643 |
|
|
! - si kopt=1 : kdat au format AAAAMMQQ |
644 |
|
|
! - si kopt=2 : kdat au format AAAAMMQQHH |
645 |
|
|
! - si kopt=3 : kdat au format AAAAMMQQHHMM |
646 |
|
|
! - si kopt=4 : kdat au format AAAAMMQQHHMMSS |
647 |
|
|
! kdat1 et kdat2 dates au format ci-dessus. |
648 |
|
|
! En sortie: |
649 |
|
|
! - si kopt=1 : kgre nombre de jours entre kdat1 et kdat2 |
650 |
|
|
! - si kopt=2 : kgre nombre d'heures entre kdat1 et kdat2 |
651 |
|
|
! - si kopt=3 : kgre nombre de minutes entre kdat1 et kdat2 |
652 |
|
|
! - si kopt=4 : kgre nombre de secondes entre kdat1 et kdat2 |
653 |
|
|
! -------------------------------------------------------------------------- |
654 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
655 |
|
|
! ATTENTION A LA PRECISION: |
656 |
|
|
! 1. Vous compilez les entiers sur 32 bits: |
657 |
|
|
! Vous devez alors vous limiter a kopt <= 2. |
658 |
|
|
! L'ecart entre les deux dates doit etre inferieur a |
659 |
|
|
! - 2**31 heures si kopt=2 |
660 |
|
|
! - 2**31 jours si kopt=1 |
661 |
|
|
! 2. Vous compilez les entiers sur 64 bits: |
662 |
|
|
! Vous pouvez utiliser toutes les valeurs de kopt. |
663 |
|
|
! L'ecart entre les deux dates doit etre inferieur a |
664 |
|
|
! - 2**63 secondes si kopt=4 |
665 |
|
|
! - 2**63 minutes si kopt=3 |
666 |
|
|
! - 2**63 heures si kopt=2 |
667 |
|
|
! - 2**63 jours si kopt=1 |
668 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
669 |
|
|
|
670 |
|
|
|
671 |
|
|
IMPLICIT NONE |
672 |
|
|
INTEGER(KIND=4) :: IGRE1 |
673 |
|
|
INTEGER(KIND=4) :: IGRE2 |
674 |
|
|
INTEGER(KIND=4) :: KDAT1 |
675 |
|
|
INTEGER(KIND=4) :: KDAT2 |
676 |
|
|
INTEGER(KIND=4) :: KGRE |
677 |
|
|
INTEGER(KIND=4) :: KOPT |
678 |
|
|
call gregod(kdat1,kopt,igre1) |
679 |
|
|
call gregod(kdat2,kopt,igre2) |
680 |
|
|
kgre=igre2-igre1 |
681 |
|
|
end |
682 |
|
|
subroutine ecartdj(k1,k2,kec) |
683 |
|
|
! -------------------------------------------------------------- |
684 |
|
|
! **** *ecartdj* Ecart en jours entre deux dates. |
685 |
|
|
! -------------------------------------------------------------- |
686 |
|
|
! Sujet: |
687 |
|
|
! Arguments explicites: |
688 |
|
|
! Arguments implicites: |
689 |
|
|
! Methode: |
690 |
|
|
! Externes: |
691 |
|
|
! Auteur: 97-11, J.M. Piriou. |
692 |
|
|
! Modifications: |
693 |
|
|
! -------------------------------------------------------------- |
694 |
|
|
! En entree: |
695 |
|
|
! k1 date de depart au format AAAAMMQQ. |
696 |
|
|
! k2 date d'arrivee au format AAAAMMQQ. |
697 |
|
|
! En sortie: |
698 |
|
|
! kec: nombre de jours entre les deux dates. |
699 |
|
|
! -------------------------------------------------------------- |
700 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
701 |
|
|
! ATTENTION A LA PRECISION: |
702 |
|
|
! Cette routine est utilisable avec des entiers 32 bits, |
703 |
|
|
! si l'ecart entre les deux dates est inferieur a 2**31 jours, |
704 |
|
|
! soit 5879489 ans!... |
705 |
|
|
! |
706 |
|
|
! Au-dela de cette duree, les entiers doivent etre 64 bits. |
707 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
708 |
|
|
! |
709 |
|
|
! ------------------------------------------------- |
710 |
|
|
! Ecart entre les deux dates au jour pres. |
711 |
|
|
! ------------------------------------------------- |
712 |
|
|
! |
713 |
|
|
|
714 |
|
|
|
715 |
|
|
IMPLICIT NONE |
716 |
|
|
INTEGER(KIND=4) :: K1 |
717 |
|
|
INTEGER(KIND=4) :: K2 |
718 |
|
|
INTEGER(KIND=4) :: KEC |
719 |
|
|
call ecartd(k1,k2,1,kec) |
720 |
|
|
end |
721 |
|
|
subroutine ecartds(cd1,cd2,kec) |
722 |
|
|
! -------------------------------------------------------------- |
723 |
|
|
! **** *ecartds* Ecart en secondes entre deux dates. |
724 |
|
|
! -------------------------------------------------------------- |
725 |
|
|
! Sujet: |
726 |
|
|
! Arguments explicites: |
727 |
|
|
! Arguments implicites: |
728 |
|
|
! Methode: |
729 |
|
|
! Externes: |
730 |
|
|
! Auteur: 97-11, J.M. Piriou. |
731 |
|
|
! Modifications: |
732 |
|
|
! -------------------------------------------------------------- |
733 |
|
|
! En entree: |
734 |
|
|
! cd1 date de depart au format 'AAAAMMQQHHNNSS'. |
735 |
|
|
! cd2 date d'arrivee au format 'AAAAMMQQHHNNSS'. |
736 |
|
|
! En sortie: |
737 |
|
|
! kec: nombre de secondes entre les deux dates. |
738 |
|
|
! -------------------------------------------------------------- |
739 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
740 |
|
|
! ATTENTION A LA PRECISION: |
741 |
|
|
! Cette routine est utilisable avec des entiers 32 bits, |
742 |
|
|
! si l'ecart entre les deux dates est inferieur a 2**31 secondes, |
743 |
|
|
! soit 68 ans!... |
744 |
|
|
! |
745 |
|
|
! Au-dela de cette duree, les entiers doivent etre 64 bits. |
746 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
747 |
|
|
|
748 |
|
|
|
749 |
|
|
IMPLICIT NONE |
750 |
|
|
INTEGER(KIND=4) :: IAMQ1 |
751 |
|
|
INTEGER(KIND=4) :: IAMQ2 |
752 |
|
|
INTEGER(KIND=4) :: IH1 |
753 |
|
|
INTEGER(KIND=4) :: IH2 |
754 |
|
|
INTEGER(KIND=4) :: IM1 |
755 |
|
|
INTEGER(KIND=4) :: IM2 |
756 |
|
|
INTEGER(KIND=4) :: IS1 |
757 |
|
|
INTEGER(KIND=4) :: IS2 |
758 |
|
|
INTEGER(KIND=4) :: KEC |
759 |
|
|
INTEGER(KIND=4) :: KECQ |
760 |
|
|
character*(*) cd1,cd2 |
761 |
|
|
! |
762 |
|
|
! ------------------------------------------------- |
763 |
|
|
! On lit les dates sur des entiers. |
764 |
|
|
! ------------------------------------------------- |
765 |
|
|
! |
766 |
|
|
read(cd1,fmt='(i8,3i2)') iamq1,ih1,im1,is1 |
767 |
|
|
read(cd2,fmt='(i8,3i2)') iamq2,ih2,im2,is2 |
768 |
|
|
! |
769 |
|
|
! ------------------------------------------------- |
770 |
|
|
! Ecart entre les deux dates au jour pres. |
771 |
|
|
! ------------------------------------------------- |
772 |
|
|
! |
773 |
|
|
call ecartd(iamq1,iamq2,1,kecq) |
774 |
|
|
! |
775 |
|
|
! ------------------------------------------------- |
776 |
|
|
! Ecart en secondes. |
777 |
|
|
! ------------------------------------------------- |
778 |
|
|
! |
779 |
|
|
kec=kecq*86400+(ih2-ih1)*3600+(im2-im1)*60+is2-is1 |
780 |
|
|
end |
781 |
|
|
subroutine gregod(kdat,kopt,kgre) |
782 |
|
|
! -------------------------------------------------------------------------- |
783 |
|
|
! **** *GREGOD * - Conversion Date > Ecart par rapport a une date fixe. |
784 |
|
|
! -------------------------------------------------------------------------- |
785 |
|
|
! Auteur: |
786 |
|
|
! ------- |
787 |
|
|
! 92-05-27, J.M. Piriou. |
788 |
|
|
! |
789 |
|
|
! Modifications: |
790 |
|
|
! -------------- |
791 |
|
|
! |
792 |
|
|
! -------------------------------------------------------------------------- |
793 |
|
|
! En entree: kopt option de precision sur les dates: |
794 |
|
|
! 1 : au jour pres |
795 |
|
|
! 2 : a l'heure pres |
796 |
|
|
! 3 : a la minute pres |
797 |
|
|
! 4 : a la seconde pres |
798 |
|
|
! - si kopt=1 : kdat au format AAAAMMQQ |
799 |
|
|
! - si kopt=2 : kdat au format AAAAMMQQHH |
800 |
|
|
! - si kopt=3 : kdat au format AAAAMMQQHHMM |
801 |
|
|
! - si kopt=4 : kdat au format AAAAMMQQHHMMSS |
802 |
|
|
! En sortie: |
803 |
|
|
! - si kopt=1 : kgre nombre de jours entre 19000101 et kdat |
804 |
|
|
! - si kopt=2 : kgre nombre d'heures entre 1900010100 et kdat |
805 |
|
|
! - si kopt=3 : kgre nombre de minutes entre 190001010000 et kdat |
806 |
|
|
! - si kopt=4 : kgre nombre de secondes entre 19000101000000 et kdat |
807 |
|
|
! -------------------------------------------------------------------------- |
808 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
809 |
|
|
! ATTENTION A LA PRECISION: |
810 |
|
|
! 1. Vous compilez les entiers sur 32 bits: |
811 |
|
|
! Vous devez alors vous limiter a kopt <= 2. |
812 |
|
|
! 2. Vous compilez les entiers sur 64 bits: |
813 |
|
|
! Vous pouvez utiliser toutes les valeurs de kopt. |
814 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
815 |
|
|
|
816 |
|
|
|
817 |
|
|
IMPLICIT NONE |
818 |
|
|
INTEGER(KIND=4) :: idebm(12) |
819 |
|
|
INTEGER(KIND=4) :: I0 |
820 |
|
|
INTEGER(KIND=4) :: IA100 |
821 |
|
|
INTEGER(KIND=4) :: IA4 |
822 |
|
|
INTEGER(KIND=4) :: IA400 |
823 |
|
|
INTEGER(KIND=4) :: IAAAA |
824 |
|
|
INTEGER(KIND=4) :: IBISSEXT |
825 |
|
|
INTEGER(KIND=4) :: ICONV |
826 |
|
|
INTEGER(KIND=4) :: IFRJOUR |
827 |
|
|
INTEGER(KIND=4) :: II |
828 |
|
|
INTEGER(KIND=4) :: II1 |
829 |
|
|
INTEGER(KIND=4) :: IJOURP |
830 |
|
|
INTEGER(KIND=4) :: IMM |
831 |
|
|
INTEGER(KIND=4) :: IN |
832 |
|
|
INTEGER(KIND=4) :: IN1 |
833 |
|
|
INTEGER(KIND=4) :: IN2 |
834 |
|
|
INTEGER(KIND=4) :: IQQ |
835 |
|
|
INTEGER(KIND=4) :: KDAT |
836 |
|
|
INTEGER(KIND=4) :: KGRE |
837 |
|
|
INTEGER(KIND=4) :: KOPT |
838 |
|
|
data idebm/0,31,59,90,120,151,181,212,243,273,304,334/ |
839 |
|
|
! |
840 |
|
|
! -------------------------------------------------------------------------- |
841 |
|
|
! ** 1. Calcul du nb de jours separant ki2 du 1er janv 1900 |
842 |
|
|
! |
843 |
|
|
! * 1.1 Extraction des quantieme, mois et annee |
844 |
|
|
if(kopt == 1) then |
845 |
|
|
! Date de type AAAAMMQQ |
846 |
|
|
iconv=1 |
847 |
|
|
ifrjour=0 |
848 |
|
|
ii=kdat |
849 |
|
|
elseif(kopt == 2) then |
850 |
|
|
! Date de type AAAAMMQQHH |
851 |
|
|
iconv=24 |
852 |
|
|
ifrjour=mod(kdat,100) |
853 |
|
|
ii=kdat/100 |
854 |
|
|
elseif(kopt == 3) then |
855 |
|
|
! Date de type AAAAMMQQHHMM |
856 |
|
|
iconv=1440 |
857 |
|
|
ifrjour=mod(kdat,100) |
858 |
|
|
ii=kdat/100 |
859 |
|
|
ifrjour=ifrjour+mod(ii,100)*60 |
860 |
|
|
ii=ii/100 |
861 |
|
|
elseif(kopt == 4) then |
862 |
|
|
! Date de type AAAAMMQQHHMMSS |
863 |
|
|
iconv=86400 |
864 |
|
|
ifrjour=mod(kdat,100) |
865 |
|
|
ii=kdat/100 |
866 |
|
|
ifrjour=ifrjour+mod(ii,100)*60 |
867 |
|
|
ii=ii/100 |
868 |
|
|
ifrjour=ifrjour+mod(ii,100)*3600 |
869 |
|
|
ii=ii/100 |
870 |
|
|
else |
871 |
|
|
! Cas d'entree erronee de l'utilisateur. |
872 |
|
|
print*,'GREGODR/ERREUR: argument kopt errone!...' |
873 |
|
|
print*,kopt |
874 |
|
|
stop 'call abort' |
875 |
|
|
endif |
876 |
|
|
iqq=ii-(ii/100)*100 |
877 |
|
|
in=(ii-iqq)/100 |
878 |
|
|
imm=in-(in/100)*100 |
879 |
|
|
iaaaa=(in-imm)/100 |
880 |
|
|
! * 1.2 L'annee est-elle bissextile? |
881 |
|
|
! Une annee est bissextile ssi elle est |
882 |
|
|
! (mult de 4 et non mult de 100) ou (mult de 400) |
883 |
|
|
iaaaa=iaaaa |
884 |
|
|
ia400=400*(iaaaa/400) |
885 |
|
|
ia100=100*(iaaaa/100) |
886 |
|
|
ia4=4*(iaaaa/4) |
887 |
|
|
if((iaaaa == ia400).or.((iaaaa == ia4).and.(iaaaa /= ia100)))then |
888 |
|
|
ibissext=1 |
889 |
|
|
else |
890 |
|
|
ibissext=0 |
891 |
|
|
endif |
892 |
|
|
if ((ibissext == 1).and.(imm > 2)) then |
893 |
|
|
ijourp=1 |
894 |
|
|
else |
895 |
|
|
ijourp=0 |
896 |
|
|
endif |
897 |
|
|
! * 1.3 Nombre de jours ecoules depuis le 1er janv |
898 |
|
|
if(imm > 12) then |
899 |
|
|
print*,'GREGODR/ERREUR: mois errone.' |
900 |
|
|
print*,imm |
901 |
|
|
stop 'call abort' |
902 |
|
|
endif |
903 |
|
|
in2=idebm(imm)+ijourp+iqq-1 |
904 |
|
|
! * 1.4 Calcul du nb de jours separant les 1er janvier de ii et 1900 |
905 |
|
|
i0=1900 |
906 |
|
|
in2=in2+365*(iaaaa-i0)+int((iaaaa-1)/4)-int((i0-1)/4)& |
907 |
|
|
&-int((iaaaa-1)/100)+int((i0-1)/100)& |
908 |
|
|
&+int((iaaaa-1)/400)-int((i0-1)/400) |
909 |
|
|
! -------------------------------------------------------------------------- |
910 |
|
|
! ** 2. Calcul du nb de jours separant ii1 du 1er janv 1900 |
911 |
|
|
! |
912 |
|
|
! * 2.1 Extraction des quantieme, mois et annee |
913 |
|
|
ii1=19000101 |
914 |
|
|
ii=ii1 |
915 |
|
|
iqq=ii-(ii/100)*100 |
916 |
|
|
in=(ii-iqq)/100 |
917 |
|
|
imm=in-(in/100)*100 |
918 |
|
|
iaaaa=(in-imm)/100 |
919 |
|
|
! * 2.2 L'annee est-elle bissextile? |
920 |
|
|
! Une annee est bissextile ssi elle est |
921 |
|
|
! (mult de 4 et non mult de 100) ou (mult de 400) |
922 |
|
|
iaaaa=iaaaa |
923 |
|
|
ia400=400*(iaaaa/400) |
924 |
|
|
ia100=100*(iaaaa/100) |
925 |
|
|
ia4=4*(iaaaa/4) |
926 |
|
|
if((iaaaa == ia400).or.((iaaaa == ia4).and.(iaaaa /= ia100)))then |
927 |
|
|
ibissext=1 |
928 |
|
|
else |
929 |
|
|
ibissext=0 |
930 |
|
|
endif |
931 |
|
|
if ((ibissext == 1).and.(imm > 2)) then |
932 |
|
|
ijourp=1 |
933 |
|
|
else |
934 |
|
|
ijourp=0 |
935 |
|
|
endif |
936 |
|
|
! * 2.3 Nombre de jours ecoules depuis le 1er janv |
937 |
|
|
in1=idebm(imm)+ijourp+iqq-1 |
938 |
|
|
! * 2.4 Calcul du nb de jours separant les 1er janvier de ii et 1900 |
939 |
|
|
i0=1900 |
940 |
|
|
in1=in1+365*(iaaaa-i0)+int((iaaaa-1)/4)-int((i0-1)/4)& |
941 |
|
|
&-int((iaaaa-1)/100)+int((i0-1)/100)& |
942 |
|
|
&+int((iaaaa-1)/400)-int((i0-1)/400) |
943 |
|
|
! -------------------------------------------------------------------------- |
944 |
|
|
! ** 3. Difference in2-in1 |
945 |
|
|
kgre=(in2-in1)*iconv+ifrjour |
946 |
|
|
end |
947 |
|
|
subroutine gregoi(kgre,kopt,kdat) |
948 |
|
|
! -------------------------------------------------------------------------- |
949 |
|
|
! **** *GREGOI * - Conversion Ecart par rapport a une date fixe > Date. |
950 |
|
|
! -------------------------------------------------------------------------- |
951 |
|
|
! Auteur: |
952 |
|
|
! ------- |
953 |
|
|
! 92-05-27, J.M. Piriou. |
954 |
|
|
! |
955 |
|
|
! Modifications: |
956 |
|
|
! -------------- |
957 |
|
|
! |
958 |
|
|
! -------------------------------------------------------------------------- |
959 |
|
|
! En entree: kopt option de precision sur les dates: |
960 |
|
|
! 1 : au jour pres |
961 |
|
|
! 2 : a l'heure pres |
962 |
|
|
! 3 : a la minute pres |
963 |
|
|
! 4 : a la seconde pres |
964 |
|
|
! - si kopt=1 : kgre nombre de jours entre 19000101 et kdat |
965 |
|
|
! - si kopt=2 : kgre nombre d'heures entre 1900010100 et kdat |
966 |
|
|
! - si kopt=3 : kgre nombre de minutes entre 190001010000 et kdat |
967 |
|
|
! - si kopt=4 : kgre nombre de secondes entre 19000101000000 et kdat |
968 |
|
|
! En sortie: |
969 |
|
|
! - si kopt=1 : kdat au format AAAAMMQQ |
970 |
|
|
! - si kopt=2 : kdat au format AAAAMMQQHH |
971 |
|
|
! - si kopt=3 : kdat au format AAAAMMQQHHMM |
972 |
|
|
! - si kopt=4 : kdat au format AAAAMMQQHHMMSS |
973 |
|
|
! -------------------------------------------------------------------------- |
974 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
975 |
|
|
! ATTENTION A LA PRECISION: |
976 |
|
|
! 1. Vous compilez les entiers sur 32 bits: |
977 |
|
|
! Vous devez alors vous limiter a kopt <= 2. |
978 |
|
|
! 2. Vous compilez les entiers sur 64 bits: |
979 |
|
|
! Vous pouvez utiliser toutes les valeurs de kopt. |
980 |
|
|
! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
981 |
|
|
|
982 |
|
|
|
983 |
|
|
IMPLICIT NONE |
984 |
|
|
INTEGER(KIND=4) :: ijours(12) |
985 |
|
|
INTEGER(KIND=4) :: IA100 |
986 |
|
|
INTEGER(KIND=4) :: IA4 |
987 |
|
|
INTEGER(KIND=4) :: IA400 |
988 |
|
|
INTEGER(KIND=4) :: IAAAA |
989 |
|
|
INTEGER(KIND=4) :: IBISSEXT |
990 |
|
|
INTEGER(KIND=4) :: ICONV |
991 |
|
|
INTEGER(KIND=4) :: IDAT |
992 |
|
|
INTEGER(KIND=4) :: IEC |
993 |
|
|
INTEGER(KIND=4) :: IECI |
994 |
|
|
INTEGER(KIND=4) :: IGII2P |
995 |
|
|
INTEGER(KIND=4) :: II2P |
996 |
|
|
INTEGER(KIND=4) :: IMM |
997 |
|
|
INTEGER(KIND=4) :: IMOD |
998 |
|
|
INTEGER(KIND=4) :: IQQ |
999 |
|
|
INTEGER(KIND=4) :: KDAT |
1000 |
|
|
INTEGER(KIND=4) :: KGRE |
1001 |
|
|
INTEGER(KIND=4) :: KOPT |
1002 |
|
|
REAL(KIND=8) :: ZARRDEC |
1003 |
|
|
data ijours/31,28,31,30,31,30,31,31,30,31,30,31/ |
1004 |
|
|
! -------------------------------------------------------------------------- |
1005 |
|
|
! ** On determine la date approximative d'arrivee en annees decimales |
1006 |
|
|
! |
1007 |
|
|
if(kopt == 1) then |
1008 |
|
|
! Date de type AAAAMMQQ |
1009 |
|
|
iconv=1 |
1010 |
|
|
elseif(kopt == 2) then |
1011 |
|
|
! Date de type AAAAMMQQHH |
1012 |
|
|
iconv=24 |
1013 |
|
|
elseif(kopt == 3) then |
1014 |
|
|
! Date de type AAAAMMQQHHMM |
1015 |
|
|
iconv=1440 |
1016 |
|
|
elseif(kopt == 4) then |
1017 |
|
|
! Date de type AAAAMMQQHHMMSS |
1018 |
|
|
iconv=86400 |
1019 |
|
|
else |
1020 |
|
|
! Cas d'entree erronee de l'utilisateur. |
1021 |
|
|
print*,'GREGOI/ERREUR: argument kopt errone!...' |
1022 |
|
|
print*,kopt |
1023 |
|
|
stop 'call abort' |
1024 |
|
|
endif |
1025 |
|
|
zarrdec=1900.+(real(kgre)/real(iconv)-5.)/365.2425 |
1026 |
|
|
! -------------------------------------------------------------------------- |
1027 |
|
|
! ** On determine la date en clair ii2p associee a la date decimale |
1028 |
|
|
! |
1029 |
|
|
iaaaa=int(zarrdec) |
1030 |
|
|
zarrdec=12.*(zarrdec-real(iaaaa)) |
1031 |
|
|
imm=int(zarrdec)+1 |
1032 |
|
|
zarrdec=28.*(zarrdec-real(imm-1)) |
1033 |
|
|
iqq=int(zarrdec)+1 |
1034 |
|
|
ii2p=iqq+imm*100+iaaaa*10000 |
1035 |
|
|
! -------------------------------------------------------------------------- |
1036 |
|
|
! ** On calcule le nombre de jours separant 19000101 de ii2p |
1037 |
|
|
! |
1038 |
|
|
call gregod(ii2p,1,igii2p) |
1039 |
|
|
imod=mod(kgre,iconv) |
1040 |
|
|
if(imod < 0) imod=imod+iconv |
1041 |
|
|
iec=(kgre-imod)/iconv-igii2p |
1042 |
|
|
! -------------------------------------------------------------------------- |
1043 |
|
|
! ** On avance de iec jours par rapport a ii2p |
1044 |
|
|
! |
1045 |
|
|
! * L'annee est-elle bissextile? |
1046 |
|
|
! Une annee est bissextile ssi elle est |
1047 |
|
|
! (mult de 4 et non mult de 100) ou (mult de 400) |
1048 |
|
|
iaaaa=iaaaa |
1049 |
|
|
ia400=400*(iaaaa/400) |
1050 |
|
|
ia100=100*(iaaaa/100) |
1051 |
|
|
ia4=4*(iaaaa/4) |
1052 |
|
|
if((iaaaa == ia400).or.((iaaaa == ia4).and.(iaaaa /= ia100)))then |
1053 |
|
|
ibissext=1 |
1054 |
|
|
else |
1055 |
|
|
ibissext=0 |
1056 |
|
|
endif |
1057 |
|
|
! Si oui, 29 jours en fevrier |
1058 |
|
|
if(ibissext == 1) ijours(2)=29 |
1059 |
|
|
! * Boucle sur les jours |
1060 |
|
|
do ieci=1,iec |
1061 |
|
|
iqq=iqq+1 |
1062 |
|
|
if(iqq > ijours(imm)) then |
1063 |
|
|
iqq=1 |
1064 |
|
|
imm=imm+1 |
1065 |
|
|
endif |
1066 |
|
|
if(imm > 12) then |
1067 |
|
|
imm=1 |
1068 |
|
|
iaaaa=iaaaa+1 |
1069 |
|
|
endif |
1070 |
|
|
enddo |
1071 |
|
|
! -------------------------------------------------------------------------- |
1072 |
|
|
! ** On met en forme la date finale |
1073 |
|
|
! |
1074 |
|
|
idat=iqq+imm*100+iaaaa*10000 |
1075 |
|
|
if(kopt == 2) then |
1076 |
|
|
imod=mod(kgre,iconv) |
1077 |
|
|
if(imod < 0) imod=imod+iconv |
1078 |
|
|
idat=idat*100+imod |
1079 |
|
|
elseif(kopt == 3) then |
1080 |
|
|
imod=mod(kgre,iconv) |
1081 |
|
|
if(imod < 0) imod=imod+iconv |
1082 |
|
|
idat=idat*100+imod/60 |
1083 |
|
|
imod=mod(imod,60) |
1084 |
|
|
idat=idat*100+imod |
1085 |
|
|
elseif(kopt == 4) then |
1086 |
|
|
imod=mod(kgre,iconv) |
1087 |
|
|
if(imod < 0) imod=imod+iconv |
1088 |
|
|
idat=idat*100+imod/3600 |
1089 |
|
|
imod=mod(imod,3600) |
1090 |
|
|
idat=idat*100+imod/60 |
1091 |
|
|
imod=mod(imod,60) |
1092 |
|
|
idat=idat*100+imod |
1093 |
|
|
endif |
1094 |
|
|
kdat=idat |
1095 |
|
|
end |
1096 |
|
|
function ijoursem(kdat) |
1097 |
|
|
! -------------------------------------------------------------------------- |
1098 |
|
|
! **** *IJOURSEM* Jour de la semaine de la date d'entree. |
1099 |
|
|
! -------------------------------------------------------------------------- |
1100 |
|
|
! Auteur: |
1101 |
|
|
! ------- |
1102 |
|
|
! 94-10-31, J.M. Piriou. |
1103 |
|
|
! |
1104 |
|
|
! Modifications: |
1105 |
|
|
! -------------- |
1106 |
|
|
! |
1107 |
|
|
! -------------------------------------------------------------------------- |
1108 |
|
|
! En entree: |
1109 |
|
|
! kdat1 au format AAAAMMQQ |
1110 |
|
|
! En sortie: |
1111 |
|
|
! ijour=0 si dimanche, 1 lundi, ..., 6 samedi. |
1112 |
|
|
! -------------------------------------------------------------------------- |
1113 |
|
|
|
1114 |
|
|
|
1115 |
|
|
IMPLICIT NONE |
1116 |
|
|
INTEGER(KIND=4) :: IDATDIM |
1117 |
|
|
INTEGER(KIND=4) :: IECART |
1118 |
|
|
INTEGER(KIND=4) :: IGRE |
1119 |
|
|
INTEGER(KIND=4) :: IGREDIM |
1120 |
|
|
INTEGER(KIND=4) :: KDAT |
1121 |
|
|
INTEGER(KIND=4) :: ijoursem |
1122 |
|
|
call gregod(kdat,1,igre) |
1123 |
|
|
idatdim=19941030 ! cette date etait un dimanche. |
1124 |
|
|
call gregod(idatdim,1,igredim) |
1125 |
|
|
iecart=igre-igredim |
1126 |
|
|
ijoursem=modulo(iecart,7) |
1127 |
|
|
end |
1128 |
|
|
subroutine qqmmaa(kdatd,cdresd) |
1129 |
|
|
! -------------------------------------------------------------------------- |
1130 |
|
|
! **** *QQMMAA * - Conversion d'un entier type AAAAQQMM vers une date en clair. |
1131 |
|
|
! -------------------------------------------------------------------------- |
1132 |
|
|
! Auteur: |
1133 |
|
|
! ------- |
1134 |
|
|
! 92-05-27, J.M. Piriou. |
1135 |
|
|
! |
1136 |
|
|
! Modifications: |
1137 |
|
|
! -------------- |
1138 |
|
|
! |
1139 |
|
|
! -------------------------------------------------------------------------- |
1140 |
|
|
|
1141 |
|
|
|
1142 |
|
|
IMPLICIT NONE |
1143 |
|
|
INTEGER(KIND=4) :: IAN |
1144 |
|
|
INTEGER(KIND=4) :: IGRE |
1145 |
|
|
INTEGER(KIND=4) :: ILOC |
1146 |
|
|
INTEGER(KIND=4) :: IMM |
1147 |
|
|
INTEGER(KIND=4) :: IQQ |
1148 |
|
|
INTEGER(KIND=4) :: KDATD |
1149 |
|
|
character*(*) cdresd |
1150 |
|
|
character*03 cljour |
1151 |
|
|
iqq=mod(kdatd,100) |
1152 |
|
|
iloc=kdatd/100 |
1153 |
|
|
imm=mod(iloc,100) |
1154 |
|
|
ian=iloc/100 |
1155 |
|
|
call gregod(kdatd,1,igre) |
1156 |
|
|
igre=mod(igre,7) |
1157 |
|
|
if(igre == 0) then |
1158 |
|
|
cljour='Lun' |
1159 |
|
|
elseif(igre == 1) then |
1160 |
|
|
cljour='Mar' |
1161 |
|
|
elseif(igre == 2) then |
1162 |
|
|
cljour='Mer' |
1163 |
|
|
elseif(igre == 3) then |
1164 |
|
|
cljour='Jeu' |
1165 |
|
|
elseif(igre == 4) then |
1166 |
|
|
cljour='Ven' |
1167 |
|
|
elseif(igre == 5) then |
1168 |
|
|
cljour='Sam' |
1169 |
|
|
elseif(igre == 6) then |
1170 |
|
|
cljour='Dim' |
1171 |
|
|
endif |
1172 |
|
|
write(cdresd,fmt='(a3,a1,i2,a1,i2.2,a1,i4.4)')& |
1173 |
|
|
&cljour,' ',iqq,'.',imm,'.',ian |
1174 |
|
|
end |
1175 |
|
|
subroutine quant(kdate,kquant) |
1176 |
|
|
! -------------------------------------------------------------- |
1177 |
|
|
! **** *quant* Quantieme de l'annee d'une date donnee. |
1178 |
|
|
! -------------------------------------------------------------- |
1179 |
|
|
! Sujet: |
1180 |
|
|
! Arguments explicites: |
1181 |
|
|
! Arguments implicites: |
1182 |
|
|
! Methode: |
1183 |
|
|
! Externes: |
1184 |
|
|
! Auteur: 1999-04, J.M. Piriou. |
1185 |
|
|
! Modifications: |
1186 |
|
|
! -------------------------------------------------------------- |
1187 |
|
|
! En entree: |
1188 |
|
|
! kdate date au format AAAAMMQQ. |
1189 |
|
|
! En sortie: |
1190 |
|
|
! quantieme de l'annee (1 le 1er janvier, 32 le 1er fevrier, etc...) |
1191 |
|
|
! -------------------------------------------------------------- |
1192 |
|
|
|
1193 |
|
|
|
1194 |
|
|
IMPLICIT NONE |
1195 |
|
|
INTEGER(KIND=4) :: IBASE |
1196 |
|
|
INTEGER(KIND=4) :: IEC |
1197 |
|
|
INTEGER(KIND=4) :: KDATE |
1198 |
|
|
INTEGER(KIND=4) :: KQUANT |
1199 |
|
|
ibase=10000*(kdate/10000)+0101 ! 1er janvier de l'annee courante. |
1200 |
|
|
call ecartdj(ibase,kdate,iec) |
1201 |
|
|
kquant=iec+1 |
1202 |
|
|
end |