| 1 | RECURSIVE SUBROUTINE jul2greg( ksec, kminut, khour, kday, kmonth, kyear, & |
|---|
| 2 | & prelday, krefdate ) |
|---|
| 3 | !!----------------------------------------------------------------------- |
|---|
| 4 | !! |
|---|
| 5 | !! *** ROUTINE jul2greg *** |
|---|
| 6 | !! |
|---|
| 7 | !! ** Purpose : Take the relative time in days and re-express in terms of |
|---|
| 8 | !! seconds, minutes, hours, days, month, year. |
|---|
| 9 | !! |
|---|
| 10 | !! ** Method : Reference date : 19500101 |
|---|
| 11 | !! |
|---|
| 12 | !! ** Action : |
|---|
| 13 | !! |
|---|
| 14 | !! History |
|---|
| 15 | !! ! 06-04 (A. Vidard) Original |
|---|
| 16 | !! ! 06-05 (A. Vidard) Reformatted and refdate |
|---|
| 17 | !! ! 06-10 (A. Weaver) Cleanup |
|---|
| 18 | !! ! 2014-09 (D. Lea) Change to use FLOOR to deal with negative prelday |
|---|
| 19 | !!----------------------------------------------------------------------- |
|---|
| 20 | |
|---|
| 21 | ! * Arguments |
|---|
| 22 | INTEGER, INTENT(IN), OPTIONAL :: & |
|---|
| 23 | & krefdate |
|---|
| 24 | INTEGER, INTENT(OUT) :: & |
|---|
| 25 | & ksec, & |
|---|
| 26 | & kminut, & |
|---|
| 27 | & khour, & |
|---|
| 28 | & kday, & |
|---|
| 29 | & kmonth, & |
|---|
| 30 | & kyear |
|---|
| 31 | REAL(KIND=dp), INTENT(IN) :: & |
|---|
| 32 | & prelday |
|---|
| 33 | |
|---|
| 34 | !! * Local declarations |
|---|
| 35 | INTEGER, PARAMETER :: & |
|---|
| 36 | & jpgreg = 2299161, & |
|---|
| 37 | & jporef = 2433283, & |
|---|
| 38 | & jparef = 2415021 |
|---|
| 39 | INTEGER :: & |
|---|
| 40 | & ijulian, & |
|---|
| 41 | & ij1, & |
|---|
| 42 | & ija, & |
|---|
| 43 | & ijb, & |
|---|
| 44 | & ijc, & |
|---|
| 45 | & ijd, & |
|---|
| 46 | & ije, & |
|---|
| 47 | & isec, & |
|---|
| 48 | & imin, & |
|---|
| 49 | & ihou, & |
|---|
| 50 | & iday, & |
|---|
| 51 | & imon, & |
|---|
| 52 | & iyea, & |
|---|
| 53 | & iref |
|---|
| 54 | REAL(KIND=dp) :: zday, zref |
|---|
| 55 | |
|---|
| 56 | |
|---|
| 57 | |
|---|
| 58 | CHARACTER(len=200) :: & |
|---|
| 59 | & cerr |
|---|
| 60 | |
|---|
| 61 | ! Main computation |
|---|
| 62 | IF ( PRESENT( krefdate ) ) THEN |
|---|
| 63 | |
|---|
| 64 | SELECT CASE ( krefdate ) |
|---|
| 65 | |
|---|
| 66 | CASE( 0 ) |
|---|
| 67 | iref = jpgreg |
|---|
| 68 | |
|---|
| 69 | CASE( 19500101 ) |
|---|
| 70 | iref = jporef |
|---|
| 71 | |
|---|
| 72 | CASE( 19000101 ) |
|---|
| 73 | iref = jparef |
|---|
| 74 | |
|---|
| 75 | CASE DEFAULT |
|---|
| 76 | WRITE(cerr,'(A,I8.8)')'jul2greg: Unknown krefdate:', krefdate |
|---|
| 77 | CALL ctl_stop( cerr ) |
|---|
| 78 | |
|---|
| 79 | END SELECT |
|---|
| 80 | |
|---|
| 81 | ELSE |
|---|
| 82 | iref = jporef |
|---|
| 83 | ENDIF |
|---|
| 84 | |
|---|
| 85 | zday = prelday |
|---|
| 86 | ksec = FLOOR( 86400. * MOD( zday, 1. ) ) |
|---|
| 87 | |
|---|
| 88 | IF ( ksec < 0. ) ksec = 86400. + ksec |
|---|
| 89 | |
|---|
| 90 | khour = ksec / 3600 |
|---|
| 91 | kminut = ( ksec - 3600 * khour ) / 60 |
|---|
| 92 | ksec = MOD( ksec , 60 ) |
|---|
| 93 | |
|---|
| 94 | ijulian = iref + INT( zday ) |
|---|
| 95 | IF ( zday < 0. ) ijulian = ijulian - 1 |
|---|
| 96 | |
|---|
| 97 | ! If input date after 10/15/1582 : |
|---|
| 98 | IF ( ijulian >= jpgreg ) THEN |
|---|
| 99 | ij1 = INT( ( DBLE( ijulian - 1867216 ) - 0.25 ) / 36524.25 ) |
|---|
| 100 | ija = ijulian + 1 + ij1 - INT( ( 0.25 * ij1 ) ) |
|---|
| 101 | ELSE |
|---|
| 102 | ija = ijulian |
|---|
| 103 | ENDIF |
|---|
| 104 | |
|---|
| 105 | ijb = ija + 1524 |
|---|
| 106 | ijc = INT( 6680. + ( DBLE ( ijb - 2439870 ) - 122.1 ) / 365.25 ) |
|---|
| 107 | ijd = 365 * ijc + INT( 0.25 * ijc ) |
|---|
| 108 | ije = INT( ( ijb - ijd ) / 30.6001 ) |
|---|
| 109 | kday = ijb - ijd - INT( 30.6001 * ije ) |
|---|
| 110 | kmonth = ije - 1 |
|---|
| 111 | IF ( kmonth > 12 ) kmonth = kmonth - 12 |
|---|
| 112 | kyear = ijc - 4715 |
|---|
| 113 | IF ( kmonth > 2 ) kyear = kyear - 1 |
|---|
| 114 | IF ( kyear <= 0 ) kyear = kyear - 1 |
|---|
| 115 | |
|---|
| 116 | END SUBROUTINE jul2greg |
|---|
