source: LMDZ6/branches/blowing_snow/libf/phylmd/rrtm/dates.F90

Last change on this file was 1990, checked in by Laurent Fairhead, 11 years ago

Corrections à la version r1989 pour permettre la compilation avec RRTM
Inclusion de la licence CeCILL_V2 pour RRTM


Changes to revision r1989 to enable RRTM code compilation
RRTM part put under CeCILL_V2 licence

  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 35.0 KB
Line 
1subroutine 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
53IMPLICIT NONE
54end
55subroutine 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
74IMPLICIT NONE
75INTEGER(KIND=4) :: kan,kmo,kqu,ihe,imi,imiv,ihev,iquv,imov,ianv,ilze
76REAL(KIND=8) :: psssss,pstati
77REAL(KIND=8) :: zs
78REAL(KIND=8) :: zsssss,zdj,zsv
79REAL(KIND=8) :: zech
80character*200 clzue,clze,clech
81character *(*) cdtit
82!
83!-------------------------------------------------
84! Date de validité.
85!-------------------------------------------------
86!
87zs=0.
88zsssss=psssss/3600.
89ihe=int(zsssss) ! heure de la base.
90zsssss=(zsssss-real(ihe))*60.
91imi=int(zsssss) ! minute de la base.
92zsssss=zsssss-real(imi)
93call amqhms_vers_dj(kan,kmo,kqu,ihe,imi,zs,zdj)
94zdj=zdj+pstati/86400. ! date julienne de validité.
95call dj_vers_amqhms(zdj,ianv,imov,iquv,ihev,imiv,zsv) ! date grégorienne de validité.
96if(pstati < 3600.) then
97!
98!-------------------------------------------------
99! Echéance en minutes.
100!-------------------------------------------------
101!
102        zech=pstati/60. ; clzue='mn'
103elseif(pstati < 259200.) then
104!
105!-------------------------------------------------
106! Echéance en heures.
107!-------------------------------------------------
108!
109        zech=pstati/3600. ; clzue='h'
110else
111!
112!-------------------------------------------------
113! Echéance en jours.
114!-------------------------------------------------
115!
116        zech=pstati/86400. ; clzue='j'
117endif
118!
119! Affichage de l'echeance avec deux chiffres apres la virgule.
120!
121write(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!
126if(clze(len_trim(clze)-2:len_trim(clze)) == '.00') then
127        clze=clze(1:len_trim(clze)-3)
128endif
129clze=adjustl(clze)
130ilze=len_trim(clze)
131clech=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!
138if(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'
148else
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'
158endif
159end
160subroutine 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
192IMPLICIT NONE
193INTEGER(KIND=4) :: idatat(8)
194INTEGER(KIND=4) :: kjs
195INTEGER(KIND=4) :: kss
196INTEGER(KIND=4) :: kmi
197INTEGER(KIND=4) :: khh
198INTEGER(KIND=4) :: kqq
199INTEGER(KIND=4) :: kmm
200INTEGER(KIND=4) :: kaaaa
201INTEGER(KIND=4) :: iaaaammqq
202INTEGER(KIND=4) :: ijoursem
203REAL(KIND=8) :: zs
204character*200 clgol1,clgol2,clgol3
205character*3 cdjs
206character*(*) cddt
207character*3 cljour(0:6)
208data cljour/'Dim','Lun','Mar','Mer','Jeu','Ven','Sam'/
209!
210!-------------------------------------------------
211! Date courante à la f90.
212!-------------------------------------------------
213!
214clgol1=' '
215clgol2=' '
216clgol3=' '
217call date_and_time(clgol1,clgol2,clgol3,idatat)
218!
219!-------------------------------------------------
220! clgol1 est du type "AAAAMMQQ".
221!-------------------------------------------------
222!
223read(clgol1,fmt='(i4,2i2)') kaaaa,kmm,kqq
224!
225!-------------------------------------------------
226! clgol2 est du type "HHMMSS.SSS".
227!-------------------------------------------------
228!
229read(clgol2,fmt='(2i2)') khh,kmi
230read(clgol2(5:),fmt=*) zs
231kss=nint(zs)
232read(clgol1,fmt='(i8)') iaaaammqq
233!
234!-------------------------------------------------
235! Jour de la semaine.
236!-------------------------------------------------
237!
238kjs=ijoursem(iaaaammqq)
239cdjs=cljour(kjs)
240!
241!-------------------------------------------------
242! Date totale.
243!-------------------------------------------------
244!
245write(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
247end
248subroutine 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
272IMPLICIT NONE
273INTEGER(KIND=4) :: IDATE1
274INTEGER(KIND=4) :: IDATE2
275INTEGER(KIND=4) :: IECART
276INTEGER(KIND=4) :: KAAAA
277INTEGER(KIND=4) :: KHH
278INTEGER(KIND=4) :: KMM
279INTEGER(KIND=4) :: KMN
280INTEGER(KIND=4) :: KQQ
281REAL(KIND=8) :: PDJ
282REAL(KIND=8) :: PS
283
284idate1=20000101
285idate2=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!
292call ecartdj(idate1,idate2,iecart)
293!
294!-------------------------------------------------
295! Date julienne.
296!-------------------------------------------------
297!
298pdj=2451545.0- 0.5 +real(iecart)+real(khh)/24. &
299& +real(kmn)/1440.+ps/86400.
300end
301subroutine 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
343IMPLICIT NONE
344INTEGER(KIND=4) :: IGRE
345INTEGER(KIND=4) :: KDAT1
346INTEGER(KIND=4) :: KDAT2
347INTEGER(KIND=4) :: KDELT
348INTEGER(KIND=4) :: KOPT
349call gregod(kdat1,kopt,igre)
350igre=igre+kdelt
351call gregoi(igre,kopt,kdat2)
352end
353subroutine 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
382IMPLICIT NONE
383INTEGER(KIND=4) :: K1
384INTEGER(KIND=4) :: K2
385INTEGER(KIND=4) :: KEC
386call daplus(k1,1,kec,k2)
387end
388subroutine 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
416IMPLICIT NONE
417INTEGER(KIND=4) :: IAMQ1
418INTEGER(KIND=4) :: IAMQ2
419INTEGER(KIND=4) :: IDELTA
420INTEGER(KIND=4) :: IECJOURS
421INTEGER(KIND=4) :: IH1
422INTEGER(KIND=4) :: IH2
423INTEGER(KIND=4) :: IM1
424INTEGER(KIND=4) :: IM2
425INTEGER(KIND=4) :: IRESTE
426INTEGER(KIND=4) :: IS1
427INTEGER(KIND=4) :: IS2
428INTEGER(KIND=4) :: ISEC
429INTEGER(KIND=4) :: KEC
430character*(*) cd1,cd2
431!
432! -------------------------------------------------
433! On lit les dates sur des entiers.
434! -------------------------------------------------
435!
436read(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!
443isec=ih1*3600+im1*60+is1 ! nombre de secondes ecoulees depuis cd10h.
444idelta=kec+isec ! nombre de secondes entre cd10h et cd2.
445ireste=modulo(idelta,86400) ! nombre de secondes entre cd20h et cd2.
446iecjours=(idelta-ireste)/86400 ! nombre de jours entre cd10h et cd20h.
447!
448! -------------------------------------------------
449! Date d'arrivee au jour pres.
450! -------------------------------------------------
451!
452call daplus(iamq1,1,iecjours,iamq2)
453!
454! -------------------------------------------------
455! Date finale a la seconde pres.
456! -------------------------------------------------
457!
458ih2=ireste/3600
459ireste=ireste-3600*ih2
460im2=ireste/60
461ireste=ireste-60*im2
462is2=ireste
463write(cd2,fmt='(i8,3i2.2)') iamq2,ih2,im2,is2
464end
465subroutine 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
495IMPLICIT NONE
496INTEGER(KIND=4) :: IDATE1
497INTEGER(KIND=4) :: IDATE2
498INTEGER(KIND=4) :: IECART
499INTEGER(KIND=4) :: KAAAA
500INTEGER(KIND=4) :: KHH
501INTEGER(KIND=4) :: KMM
502INTEGER(KIND=4) :: KMN
503INTEGER(KIND=4) :: KNOUV
504INTEGER(KIND=4) :: KQQ
505REAL(KIND=8) :: PDJ
506REAL(KIND=8) :: PS
507REAL(KIND=8) :: ZECART
508REAL(KIND=8) :: ZFRAC
509zecart=pdj-2451544.5
510!
511!-------------------------------------------------
512! Nombre entier de jours.
513!-------------------------------------------------
514!
515zfrac=modulo(zecart, 1._8 )
516iecart=nint(zecart-zfrac)
517!
518!-------------------------------------------------
519! Date grégorienne associée.
520!-------------------------------------------------
521!
522idate1=20000101
523call daplusj(idate1,iecart,idate2)
524kqq=mod(idate2,100)
525knouv=idate2/100
526kmm=mod(knouv,100)
527kaaaa=knouv/100
528!
529!-------------------------------------------------
530! Calcul de des heure, minute et seconde.
531!-------------------------------------------------
532!
533zfrac=(zecart-real(iecart))*24.
534khh=int(zfrac)
535zfrac=(zfrac-real(khh))*60.
536kmn=int(zfrac)
537ps=(zfrac-real(kmn))*60.
538end
539subroutine 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
558IMPLICIT NONE
559REAL(KIND=8), intent(in) :: PDJ
560REAL(KIND=8), intent(out) :: pgrer
561REAL(KIND=8) :: ZS
562INTEGER(KIND=4) :: iaaaa,imm,iqq,ihh,imn
563!
564!-------------------------------------------------
565! Conversion grégorien julien; cible 5 entiers et un réel.
566!-------------------------------------------------
567!
568call 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!
574pgrer=real(iaaaa)*10000.+real(imm)*100. &
575& + real(iqq)+real(ihh)/100. &
576& + real(imn)/10000.+zs/1.E+06
577end
578subroutine 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
597IMPLICIT NONE
598REAL(KIND=8), intent(out) :: PDJ
599REAL(KIND=8), intent(in) :: pgrer
600REAL(KIND=8) :: ZS,zloc
601INTEGER(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!
608iloc=int(pgrer)
609iqq=mod(iloc,100)
610iloc=iloc/100
611imm=mod(iloc,100)
612iaaaa=iloc/100
613
614iloc=nint((pgrer-real(int(pgrer)))*1.E+06)
615zs=real(mod(iloc,100))
616iloc=iloc/100
617imn=mod(iloc,100)
618ihh=iloc/100
619!
620!-------------------------------------------------
621! Conversion grégorien julien; cible 5 entiers et un réel.
622!-------------------------------------------------
623!
624call amqhms_vers_dj(iaaaa,imm,iqq,ihh,imn,zs,pdj)
625end
626subroutine 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
671IMPLICIT NONE
672INTEGER(KIND=4) :: IGRE1
673INTEGER(KIND=4) :: IGRE2
674INTEGER(KIND=4) :: KDAT1
675INTEGER(KIND=4) :: KDAT2
676INTEGER(KIND=4) :: KGRE
677INTEGER(KIND=4) :: KOPT
678call gregod(kdat1,kopt,igre1)
679call gregod(kdat2,kopt,igre2)
680kgre=igre2-igre1
681end
682subroutine 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
715IMPLICIT NONE
716INTEGER(KIND=4) :: K1
717INTEGER(KIND=4) :: K2
718INTEGER(KIND=4) :: KEC
719call ecartd(k1,k2,1,kec)
720end
721subroutine 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
749IMPLICIT NONE
750INTEGER(KIND=4) :: IAMQ1
751INTEGER(KIND=4) :: IAMQ2
752INTEGER(KIND=4) :: IH1
753INTEGER(KIND=4) :: IH2
754INTEGER(KIND=4) :: IM1
755INTEGER(KIND=4) :: IM2
756INTEGER(KIND=4) :: IS1
757INTEGER(KIND=4) :: IS2
758INTEGER(KIND=4) :: KEC
759INTEGER(KIND=4) :: KECQ
760character*(*) cd1,cd2
761!
762! -------------------------------------------------
763! On lit les dates sur des entiers.
764! -------------------------------------------------
765!
766read(cd1,fmt='(i8,3i2)') iamq1,ih1,im1,is1
767read(cd2,fmt='(i8,3i2)') iamq2,ih2,im2,is2
768!
769! -------------------------------------------------
770! Ecart entre les deux dates au jour pres.
771! -------------------------------------------------
772!
773call ecartd(iamq1,iamq2,1,kecq)
774!
775! -------------------------------------------------
776! Ecart en secondes.
777! -------------------------------------------------
778!
779kec=kecq*86400+(ih2-ih1)*3600+(im2-im1)*60+is2-is1
780end
781subroutine 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
817IMPLICIT NONE
818INTEGER(KIND=4) :: idebm(12)
819INTEGER(KIND=4) :: I0
820INTEGER(KIND=4) :: IA100
821INTEGER(KIND=4) :: IA4
822INTEGER(KIND=4) :: IA400
823INTEGER(KIND=4) :: IAAAA
824INTEGER(KIND=4) :: IBISSEXT
825INTEGER(KIND=4) :: ICONV
826INTEGER(KIND=4) :: IFRJOUR
827INTEGER(KIND=4) :: II
828INTEGER(KIND=4) :: II1
829INTEGER(KIND=4) :: IJOURP
830INTEGER(KIND=4) :: IMM
831INTEGER(KIND=4) :: IN
832INTEGER(KIND=4) :: IN1
833INTEGER(KIND=4) :: IN2
834INTEGER(KIND=4) :: IQQ
835INTEGER(KIND=4) :: KDAT
836INTEGER(KIND=4) :: KGRE
837INTEGER(KIND=4) :: KOPT
838data 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
844if(kopt == 1) then
845  ! Date de type AAAAMMQQ
846  iconv=1
847  ifrjour=0
848  ii=kdat
849elseif(kopt == 2) then
850  ! Date de type AAAAMMQQHH
851  iconv=24
852  ifrjour=mod(kdat,100)
853  ii=kdat/100
854elseif(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
861elseif(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
870else
871  ! Cas d'entree erronee de l'utilisateur.
872  print*,'GREGODR/ERREUR: argument kopt errone!...'
873  print*,kopt
874  stop 'call abort'
875endif
876iqq=ii-(ii/100)*100
877in=(ii-iqq)/100
878imm=in-(in/100)*100
879iaaaa=(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)
883iaaaa=iaaaa
884ia400=400*(iaaaa/400)
885ia100=100*(iaaaa/100)
886ia4=4*(iaaaa/4)
887if((iaaaa == ia400).or.((iaaaa == ia4).and.(iaaaa /= ia100)))then
888  ibissext=1
889else
890  ibissext=0
891endif
892if ((ibissext == 1).and.(imm > 2)) then
893  ijourp=1
894else
895  ijourp=0
896endif
897! *       1.3 Nombre de jours ecoules depuis le 1er janv
898if(imm > 12) then
899  print*,'GREGODR/ERREUR: mois errone.'
900  print*,imm
901  stop 'call abort'
902endif
903in2=idebm(imm)+ijourp+iqq-1
904! *       1.4 Calcul du nb de jours separant les 1er janvier de ii et 1900
905i0=1900
906in2=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
913ii1=19000101
914ii=ii1
915iqq=ii-(ii/100)*100
916in=(ii-iqq)/100
917imm=in-(in/100)*100
918iaaaa=(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)
922iaaaa=iaaaa
923ia400=400*(iaaaa/400)
924ia100=100*(iaaaa/100)
925ia4=4*(iaaaa/4)
926if((iaaaa == ia400).or.((iaaaa == ia4).and.(iaaaa /= ia100)))then
927  ibissext=1
928else
929  ibissext=0
930endif
931if ((ibissext == 1).and.(imm > 2)) then
932  ijourp=1
933else
934  ijourp=0
935endif
936! *       2.3 Nombre de jours ecoules depuis le 1er janv
937in1=idebm(imm)+ijourp+iqq-1
938! *       2.4 Calcul du nb de jours separant les 1er janvier de ii et 1900
939i0=1900
940in1=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
945kgre=(in2-in1)*iconv+ifrjour
946end
947subroutine 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
983IMPLICIT NONE
984INTEGER(KIND=4) :: ijours(12)
985INTEGER(KIND=4) :: IA100
986INTEGER(KIND=4) :: IA4
987INTEGER(KIND=4) :: IA400
988INTEGER(KIND=4) :: IAAAA
989INTEGER(KIND=4) :: IBISSEXT
990INTEGER(KIND=4) :: ICONV
991INTEGER(KIND=4) :: IDAT
992INTEGER(KIND=4) :: IEC
993INTEGER(KIND=4) :: IECI
994INTEGER(KIND=4) :: IGII2P
995INTEGER(KIND=4) :: II2P
996INTEGER(KIND=4) :: IMM
997INTEGER(KIND=4) :: IMOD
998INTEGER(KIND=4) :: IQQ
999INTEGER(KIND=4) :: KDAT
1000INTEGER(KIND=4) :: KGRE
1001INTEGER(KIND=4) :: KOPT
1002REAL(KIND=8) :: ZARRDEC
1003data 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!
1007if(kopt == 1) then
1008  ! Date de type AAAAMMQQ
1009  iconv=1
1010elseif(kopt == 2) then
1011  ! Date de type AAAAMMQQHH
1012  iconv=24
1013elseif(kopt == 3) then
1014  ! Date de type AAAAMMQQHHMM
1015  iconv=1440
1016elseif(kopt == 4) then
1017  ! Date de type AAAAMMQQHHMMSS
1018  iconv=86400
1019else
1020  ! Cas d'entree erronee de l'utilisateur.
1021  print*,'GREGOI/ERREUR: argument kopt errone!...'
1022  print*,kopt
1023  stop 'call abort'
1024endif
1025zarrdec=1900.+(real(kgre)/real(iconv)-5.)/365.2425
1026! --------------------------------------------------------------------------
1027! **   On determine la date en clair ii2p associee a la date decimale
1028!
1029iaaaa=int(zarrdec)
1030zarrdec=12.*(zarrdec-real(iaaaa))
1031imm=int(zarrdec)+1
1032zarrdec=28.*(zarrdec-real(imm-1))
1033iqq=int(zarrdec)+1
1034ii2p=iqq+imm*100+iaaaa*10000
1035! --------------------------------------------------------------------------
1036! **   On calcule le nombre de jours separant 19000101 de ii2p
1037!
1038call gregod(ii2p,1,igii2p)
1039imod=mod(kgre,iconv)
1040if(imod < 0) imod=imod+iconv
1041iec=(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)
1048iaaaa=iaaaa
1049ia400=400*(iaaaa/400)
1050ia100=100*(iaaaa/100)
1051ia4=4*(iaaaa/4)
1052if((iaaaa == ia400).or.((iaaaa == ia4).and.(iaaaa /= ia100)))then
1053  ibissext=1
1054else
1055  ibissext=0
1056endif
1057! Si oui, 29 jours en fevrier
1058if(ibissext == 1) ijours(2)=29
1059! *       Boucle sur les jours
1060do 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
1070enddo
1071! --------------------------------------------------------------------------
1072! **   On met en forme la date finale
1073!
1074idat=iqq+imm*100+iaaaa*10000
1075if(kopt == 2) then
1076  imod=mod(kgre,iconv)
1077  if(imod < 0) imod=imod+iconv
1078  idat=idat*100+imod
1079elseif(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
1085elseif(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
1093endif
1094kdat=idat
1095end
1096function 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
1115IMPLICIT NONE
1116INTEGER(KIND=4) :: IDATDIM
1117INTEGER(KIND=4) :: IECART
1118INTEGER(KIND=4) :: IGRE
1119INTEGER(KIND=4) :: IGREDIM
1120INTEGER(KIND=4) :: KDAT
1121INTEGER(KIND=4) :: ijoursem
1122call gregod(kdat,1,igre)
1123idatdim=19941030 ! cette date etait un dimanche.
1124call gregod(idatdim,1,igredim)
1125iecart=igre-igredim
1126ijoursem=modulo(iecart,7)
1127end
1128subroutine 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
1142IMPLICIT NONE
1143INTEGER(KIND=4) :: IAN
1144INTEGER(KIND=4) :: IGRE
1145INTEGER(KIND=4) :: ILOC
1146INTEGER(KIND=4) :: IMM
1147INTEGER(KIND=4) :: IQQ
1148INTEGER(KIND=4) :: KDATD
1149character*(*) cdresd
1150character*03 cljour
1151iqq=mod(kdatd,100)
1152iloc=kdatd/100
1153imm=mod(iloc,100)
1154ian=iloc/100
1155call gregod(kdatd,1,igre)
1156igre=mod(igre,7)
1157if(igre == 0) then
1158  cljour='Lun'
1159elseif(igre == 1) then
1160  cljour='Mar'
1161elseif(igre == 2) then
1162  cljour='Mer'
1163elseif(igre == 3) then
1164  cljour='Jeu'
1165elseif(igre == 4) then
1166  cljour='Ven'
1167elseif(igre == 5) then
1168  cljour='Sam'
1169elseif(igre == 6) then
1170  cljour='Dim'
1171endif
1172write(cdresd,fmt='(a3,a1,i2,a1,i2.2,a1,i4.4)')&
1173&cljour,' ',iqq,'.',imm,'.',ian
1174end
1175subroutine 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
1194IMPLICIT NONE
1195INTEGER(KIND=4) :: IBASE
1196INTEGER(KIND=4) :: IEC
1197INTEGER(KIND=4) :: KDATE
1198INTEGER(KIND=4) :: KQUANT
1199ibase=10000*(kdate/10000)+0101 ! 1er janvier de l'annee courante.
1200call ecartdj(ibase,kdate,iec)
1201kquant=iec+1
1202end
Note: See TracBrowser for help on using the repository browser.