LOGICAL FUNCTION ISALEAP(IY) 5ZPDATE1.60
! ZPDATE1.61
! Returns .TRUE. if IY is a Leap year ZPDATE1.62
! Returns .FALSE. if IY is not a Leap year ZPDATE1.63
! ZPDATE1.64
IMPLICIT NONE ZPDATE1.65
! INPUT ARGUMENT ZPDATE1.66
INTEGER, INTENT(IN) :: IY ZPDATE1.67
ZPDATE1.68
ZPDATE1.69
IF (IY/4*4 .NE. IY) THEN ! Divide by 4 ZPDATE1.70
ISALEAP=.FALSE. ZPDATE1.71
ELSE ZPDATE1.72
IF (IY/400*400 .EQ. IY) THEN ! Century check ZPDATE1.73
ISALEAP=.TRUE. ZPDATE1.74
ELSE ZPDATE1.75
IF (IY/100*100 .EQ. IY) THEN ! Century qualifier ZPDATE1.76
ISALEAP=.FALSE. ZPDATE1.77
ELSE ZPDATE1.78
ISALEAP=.TRUE. ZPDATE1.79
ENDIF ZPDATE1.80
ENDIF ZPDATE1.81
ENDIF ZPDATE1.82
END FUNCTION ISALEAP ZPDATE1.83
ZPDATE1.84
!----------------------------------------------------------------------- ZPDATE1.85
ZPDATE1.86
SUBROUTINE ZPDATE ZPDATE1.87
! ZPDATE1.88
! Prints version information ZPDATE1.89
! ZPDATE1.90
PRINT *, ' ZPDATE - F90 fixed format module-free version ZPDATE1.91
& (Y2K Compliance Checked)' ZPDATE1.92
PRINT *, ' LAST MODIFIED MONDAY 5th October 1998' ZPDATE1.93
PRINT *, ' by Stephen Turner (DD)' ZPDATE1.94
PRINT *, ' Contact Software Engineering Group with any queries.' ZPDATE1.95
RETURN ZPDATE1.96
END SUBROUTINE ZPDATE ZPDATE1.97
ZPDATE1.98
!----------------------------------------------------------------------- ZPDATE1.99
SUBROUTINE DATE21 (IDY, IY, ICD) ZPDATE1.100
! ZPDATE1.101
! DAYS SINCE 1.1.1900, FROM DAY OF YEAR ZPDATE1.102
! ZPDATE1.103
IMPLICIT NONE ZPDATE1.104
! INPUT ARGUMENTS ZPDATE1.105
INTEGER, INTENT(IN) :: IDY, IY ZPDATE1.106
! OUTPUT ARGUMENTS ZPDATE1.107
INTEGER, INTENT(OUT) :: ICD ZPDATE1.108
! LOCAL VARIABLES ZPDATE1.109
INTEGER :: IYN ZPDATE1.110
ZPDATE1.111
IYN = IY - 1900 ZPDATE1.112
IF (IYN .GT. 0) THEN ZPDATE1.113
ICD = IDY + IYN*365 + (IYN-1)/4 - (IYN-1)/100 + (IYN+299)/400 ZPDATE1.114
ELSE ZPDATE1.115
ICD = IDY + IYN*365 + IYN/4 - IYN/100 ZPDATE1.116
ENDIF ZPDATE1.117
ZPDATE1.118
END SUBROUTINE DATE21 ZPDATE1.119
!----------------------------------------------------------------------- ZPDATE1.120
SUBROUTINE DATE23 (IDY, IY, ID, IM, INY) ,1ZPDATE1.121
! ZPDATE1.122
! DAY, MONTH, YEAR FROM DAY OF YEAR ZPDATE1.123
! ZPDATE1.124
IMPLICIT NONE ZPDATE1.125
! INPUT ARGUMENTS ZPDATE1.126
INTEGER, INTENT(IN) :: IDY, IY ZPDATE1.127
! OUTPUT ARGUMENTS ZPDATE1.128
INTEGER, INTENT(OUT) :: ID, IM, INY ZPDATE1.129
! LOCAL VARIABLES ZPDATE1.130
INTEGER :: I, K, days_in_feb ZPDATE1.131
INTEGER, DIMENSION(12) :: MONTHS ZPDATE1.132
! external function ZPDATE1.133
LOGICAL, EXTERNAL :: ISALEAP ZPDATE1.134
ZPDATE1.135
IF (ISALEAP
(IY)) THEN ZPDATE1.136
days_in_feb = 29 ZPDATE1.137
ELSE ZPDATE1.138
days_in_feb = 28 ZPDATE1.139
ENDIF ZPDATE1.140
ZPDATE1.141
ZPDATE1.142
MONTHS = (/31,days_in_feb,31,30,31,30,31,31,30,31,30,31/) ZPDATE1.143
K = IDY ZPDATE1.144
ZPDATE1.145
DO I=1,12 ZPDATE1.146
K = K - MONTHS(I) ZPDATE1.147
IF (K .GT. 0) THEN ZPDATE1.148
CYCLE ZPDATE1.149
ELSE ZPDATE1.150
ID = K + MONTHS(I) ZPDATE1.151
IM = I ZPDATE1.152
INY = IY ZPDATE1.153
ENDIF ZPDATE1.154
EXIT ZPDATE1.155
END DO ZPDATE1.156
ZPDATE1.157
END SUBROUTINE DATE23 ZPDATE1.158
!----------------------------------------------------------------------- ZPDATE1.159
SUBROUTINE DATE13 (ICD, ID, IM, INY) 2,1ZPDATE1.160
! ZPDATE1.161
! DAY, MONTH, YEAR FROM DAYS SINCE 1.1.1900 ZPDATE1.162
! ZPDATE1.163
IMPLICIT NONE ZPDATE1.164
! INPUT ARGUMENTS ZPDATE1.165
INTEGER, INTENT(IN) :: ICD ZPDATE1.166
! OUTPUT ARGUMENTS ZPDATE1.167
INTEGER, INTENT(OUT) :: ID, IM, INY ZPDATE1.168
! LOCAL VARIABLES ZPDATE1.169
INTEGER :: IDY, IY ZPDATE1.170
INTEGER :: K,KD,KE,KY,I,K1X, days_in_feb ZPDATE1.171
INTEGER, DIMENSION(12) :: MONTHS ZPDATE1.172
! external function ZPDATE1.173
LOGICAL, EXTERNAL :: ISALEAP ZPDATE1.174
ZPDATE1.175
K = ICD ZPDATE1.176
KE = 0 ZPDATE1.177
IF (K .GE. 366) THEN ! these allow for the non-leap years 1900 ZPDATE1.178
K = K + 1 ZPDATE1.179
IF (K .GE. 73416) THEN !2100, ... ZPDATE1.180
K = K + 1 ZPDATE1.181
IF (K .GE. 109941) THEN !2200, ZPDATE1.182
K = K + 1 ZPDATE1.183
IF (K .GE. 146466) THEN !2300 ... ZPDATE1.184
K = K + 1 ZPDATE1.185
ENDIF ZPDATE1.186
ENDIF ZPDATE1.187
ENDIF ZPDATE1.188
ENDIF ZPDATE1.189
IF (K .LE. -36159) THEN ! and 1800 respectively ZPDATE1.190
K = K - 1 ZPDATE1.191
ENDIF ZPDATE1.192
ZPDATE1.193
KY = K/1461*4 ZPDATE1.194
KD = K - K/1461*1461 ZPDATE1.195
IF (KD .LT. 0) THEN ZPDATE1.196
KD = KD + 1461 ZPDATE1.197
KY = KY - 4 ZPDATE1.198
ENDIF ZPDATE1.199
KY = KY + 1900 ZPDATE1.200
IF (KD .GT. 366) THEN ZPDATE1.201
KD = KD - 1 ZPDATE1.202
KE = KD/365 ZPDATE1.203
KD = KD - KD/365*365 ZPDATE1.204
ENDIF ZPDATE1.205
IF (KD .EQ. 0) THEN ZPDATE1.206
KE = KE - 1 ZPDATE1.207
KD = 365 ZPDATE1.208
ENDIF ZPDATE1.209
INY = KY + KE ZPDATE1.210
IDY = KD ZPDATE1.211
IY = INY ZPDATE1.212
ZPDATE1.213
IF (ISALEAP(IY)) THEN ZPDATE1.214
days_in_feb = 29 ZPDATE1.215
ELSE ZPDATE1.216
days_in_feb = 28 ZPDATE1.217
ENDIF ZPDATE1.218
ZPDATE1.219
MONTHS = (/31,days_in_feb,31,30,31,30,31,31,30,31,30,31/) ZPDATE1.220
ZPDATE1.221
K1X = IDY ZPDATE1.222
ZPDATE1.223
DO I=1,12 ZPDATE1.224
K1X = K1X - MONTHS(I) ZPDATE1.225
IF (K1X .GT. 0) THEN ZPDATE1.226
CYCLE ZPDATE1.227
ELSE ZPDATE1.228
ID = K1X + MONTHS(I) ZPDATE1.229
IM = I ZPDATE1.230
INY = IY ZPDATE1.231
ZPDATE1.232
ENDIF ZPDATE1.233
EXIT ZPDATE1.234
END DO ZPDATE1.235
ZPDATE1.236
END SUBROUTINE DATE13 ZPDATE1.237
!----------------------------------------------------------------------- ZPDATE1.238
SUBROUTINE DATE31 (ID, IM, IY, ICD) 5,2ZPDATE1.239
! ZPDATE1.240
! DAYS SINCE 1.1.1900 FROM DAY, MONTH, YEAR ZPDATE1.241
! ZPDATE1.242
IMPLICIT NONE ZPDATE1.243
! INPUT ARGUMENTS ZPDATE1.244
INTEGER, INTENT(IN) :: ID, IM, IY ZPDATE1.245
! OUTPUT ARGUMENTS ZPDATE1.246
INTEGER, INTENT(OUT) :: ICD ZPDATE1.247
! LOCAL VARIABLES ZPDATE1.248
INTEGER :: IDY, INY ZPDATE1.249
INTEGER :: K,IYN, days_in_feb ZPDATE1.250
INTEGER, DIMENSION(12) :: MONTHS ZPDATE1.251
! external function ZPDATE1.252
LOGICAL, EXTERNAL :: ISALEAP ZPDATE1.253
ZPDATE1.254
IF (ISALEAP(IY)) THEN ZPDATE1.255
days_in_feb = 29 ZPDATE1.256
ELSE ZPDATE1.257
days_in_feb = 28 ZPDATE1.258
ENDIF ZPDATE1.259
ZPDATE1.260
MONTHS = (/31,days_in_feb,31,30,31,30,31,31,30,31,30,31/) ZPDATE1.261
ZPDATE1.262
K = SUM(MONTHS(1:(IM-1))) ! use array sections and intrinsics ZPDATE1.263
ZPDATE1.264
IDY = K + ID ZPDATE1.265
INY = IY ZPDATE1.266
IYN = INY - 1900 ZPDATE1.267
IF (IYN .GT. 0) THEN ZPDATE1.268
ICD = IDY + IYN*365 + (IYN-1)/4 - (IYN-1)/100 + (IYN+299)/400 ZPDATE1.269
ELSE ZPDATE1.270
ICD = IDY + IYN*365 + IYN/4 - IYN/100 ZPDATE1.271
ENDIF ZPDATE1.272
ZPDATE1.273
ZPDATE1.274
END SUBROUTINE DATE31 ZPDATE1.275
!----------------------------------------------------------------------- ZPDATE1.276
SUBROUTINE DATE12(ICD,IDY,IY) ZPDATE1.277
! ZPDATE1.278
! DAY OF YEAR FROM DAYS SINCE 1.1.1900 ZPDATE1.279
! ZPDATE1.280
IMPLICIT NONE ZPDATE1.281
! INPUT ARGUMENTS ZPDATE1.282
INTEGER, INTENT(IN) :: ICD ZPDATE1.283
! OUTPUT ARGUMENTS ZPDATE1.284
INTEGER, INTENT(OUT) :: IDY, IY ZPDATE1.285
! LOCAL VARIABLES ZPDATE1.286
INTEGER :: K, KD, KE, KY ZPDATE1.287
ZPDATE1.288
K = ICD ZPDATE1.289
KE = 0 ZPDATE1.290
IF (K .GE. 366) THEN ZPDATE1.291
K = K + 1 ZPDATE1.292
IF (K .GE. 73416) THEN ZPDATE1.293
K = K + 1 ZPDATE1.294
IF (K .GE. 109941) THEN ZPDATE1.295
K = K + 1 ZPDATE1.296
IF (K .GE. 146466) THEN ZPDATE1.297
K = K + 1 ZPDATE1.298
ENDIF ZPDATE1.299
ENDIF ZPDATE1.300
ENDIF ZPDATE1.301
ENDIF ZPDATE1.302
IF (K .LE. -36159) THEN ZPDATE1.303
K = K - 1 ZPDATE1.304
ENDIF ZPDATE1.305
KY = K/1461*4 ZPDATE1.306
KD = K - K/1461*1461 ZPDATE1.307
IF (KD .LT. 0) THEN ZPDATE1.308
KD = KD + 1461 ZPDATE1.309
KY = KY - 4 ZPDATE1.310
ENDIF ZPDATE1.311
KY = KY + 1900 ZPDATE1.312
IF (KD .GT. 366) THEN ZPDATE1.313
KD = KD - 1 ZPDATE1.314
KE = KD/365 ZPDATE1.315
KD = KD - KD/365*365 ZPDATE1.316
ENDIF ZPDATE1.317
IF (KD .EQ. 0) THEN ZPDATE1.318
KE = KE - 1 ZPDATE1.319
KD = 365 ZPDATE1.320
ENDIF ZPDATE1.321
IY = KY + KE ZPDATE1.322
IDY = KD ZPDATE1.323
ZPDATE1.324
END SUBROUTINE DATE12 ZPDATE1.325
!----------------------------------------------------------------------- ZPDATE1.326
SUBROUTINE DATE32(ID,IM,IY,IDY,INY) ZPDATE1.327
! ZPDATE1.328
! DAY OF YEAR FROM DAY, MONTH, YEAR ZPDATE1.329
! ZPDATE1.330
IMPLICIT NONE ZPDATE1.331
! INPUT ARGUMENTS ZPDATE1.332
INTEGER, INTENT(IN) :: ID, IM, IY ZPDATE1.333
! OUTPUT ARGUMENTS ZPDATE1.334
INTEGER, INTENT(OUT) :: IDY, INY ZPDATE1.335
! LOCAL VARIABLES ZPDATE1.336
INTEGER :: K, days_in_feb ZPDATE1.337
INTEGER, DIMENSION(12) :: MONTHS ZPDATE1.338
! external function ZPDATE1.339
LOGICAL, EXTERNAL :: ISALEAP ZPDATE1.340
ZPDATE1.341
IF (ISALEAP(IY)) THEN ZPDATE1.342
days_in_feb = 29 ZPDATE1.343
ELSE ZPDATE1.344
days_in_feb = 28 ZPDATE1.345
ENDIF ZPDATE1.346
ZPDATE1.347
MONTHS = (/31,days_in_feb,31,30,31,30,31,31,30,31,30,31/) ZPDATE1.348
ZPDATE1.349
K = SUM(MONTHS(1:(IM-1))) !use array sections and intrinsics ZPDATE1.350
ZPDATE1.351
IDY = K + ID ZPDATE1.352
INY = IY ZPDATE1.353
ZPDATE1.354
END SUBROUTINE DATE32 ZPDATE1.355
ZPDATE1.356
ZPDATE1.357
!----------------------------------------------------------------------- ZPDATE1.358
INTEGER FUNCTION MNTHDS(MONTH,YEAR) 1,1ZPDATE1.359
! ZPDATE1.360
! Returns Days in Month from Month and Year. ZPDATE1.361
! ZPDATE1.362
IMPLICIT NONE ZPDATE1.363
! INPUT ARGUMENTS ZPDATE1.364
INTEGER, INTENT(IN) :: MONTH,YEAR ZPDATE1.365
! LOCAL VARIABLES ZPDATE1.366
ZPDATE1.367
LOGICAL, EXTERNAL :: ISALEAP ZPDATE1.368
ZPDATE1.369
SELECT CASE (MONTH) ZPDATE1.370
CASE (1,3,5,7,8,10,12) ZPDATE1.371
MNTHDS = 31 ZPDATE1.372
CASE (4,6,9,11) ZPDATE1.373
MNTHDS = 30 ZPDATE1.374
CASE (2) ZPDATE1.375
IF (ISALEAP(YEAR)) THEN ZPDATE1.376
MNTHDS = 29 ZPDATE1.377
ELSE ZPDATE1.378
MNTHDS = 28 ZPDATE1.379
ENDIF ZPDATE1.380
CASE DEFAULT ZPDATE1.381
PRINT *, "Error in function MNTHDS" ZPDATE1.382
RETURN ZPDATE1.383
END SELECT ZPDATE1.384
ZPDATE1.385
END FUNCTION MNTHDS ZPDATE1.386
!----------------------------------------------------------------------- ZPDATE1.387
SUBROUTINE DATCHK (DAY,MONTH,YEAR,VALID) ,1ZPDATE1.388
! ZPDATE1.389
! Checks the date and returns to a given statement for invalid ZPDATE1.390
! values ZPDATE1.391
! ZPDATE1.392
IMPLICIT NONE ZPDATE1.393
INTEGER, INTENT(IN) :: DAY,MONTH,YEAR ZPDATE1.394
LOGICAL, INTENT(OUT) :: VALID ZPDATE1.395
ZPDATE1.396
INTEGER :: LDAY ZPDATE1.397
INTEGER :: LMNTH ZPDATE1.398
INTEGER, EXTERNAL :: MNTHDS ZPDATE1.399
ZPDATE1.400
ZPDATE1.401
IF (YEAR .EQ. 1752) THEN ZPDATE1.402
LDAY=14 ZPDATE1.403
LMNTH=9 ZPDATE1.404
ELSE ZPDATE1.405
LDAY=1 ZPDATE1.406
LMNTH=1 ZPDATE1.407
ENDIF ZPDATE1.408
ZPDATE1.409
! Check that within valid year range ZPDATE1.410
! Check that within valid month range ZPDATE1.411
! and check that within valid day range ZPDATE1.412
ZPDATE1.413
IF ((YEAR .GE. 1752) .AND. ZPDATE1.414
& (YEAR .LE. 2399) .AND. ZPDATE1.415
& (MONTH .GE. LMNTH) .AND. ZPDATE1.416
& (MONTH .LE. 12) .AND. ZPDATE1.417
& (DAY .GE. LDAY) .AND. ZPDATE1.418
& (DAY .LE. MNTHDS(MONTH,YEAR))) THEN ZPDATE1.419
! Valid date, so return from here ZPDATE1.420
VALID=.TRUE. ZPDATE1.421
ELSE ZPDATE1.422
VALID=.FALSE. ZPDATE1.423
ENDIF ZPDATE1.424
RETURN ZPDATE1.425
END SUBROUTINE DATCHK ZPDATE1.426
!----------------------------------------------------------------------- ZPDATE1.427
! The JDATE Conversion algorithms are based on the algorithm published ZPDATE1.428
! in a letter to the editor of Communications of the ACM (CACM, volume 1 ZPDATE1.429
! number 10, October 1968, p.657) by Henry F. Fliegel and ZPDATE1.430
! Thomas Van Flandern ZPDATE1.431
! This algorithm is valid only for dates from ZPDATE1.432
! 1/3/-4900 G onward when converting from a Julian day number to a date, ZPDATE1.433
! or from 1/3/-4800 when converting from a date to a Julian day number. ZPDATE1.434
! It should be noted that these algorithms are valid only in the ZPDATE1.435
! Gregorian Calendar and the Proleptic Gregorian Calendar (after the ZPDATE1.436
! dates given above). They do not handle dates in the Julian Calendar. ZPDATE1.437
!----------------------------------------------------------------------- ZPDATE1.438
SUBROUTINE JDATE31(ID,IM,IY,OD) ZPDATE1.439
! ZPDATE1.440
! Returns the Julian Day Number for a Day, Month, Year ZPDATE1.441
! ZPDATE1.442
IMPLICIT NONE ZPDATE1.443
! INPUT ARGUMENTS ZPDATE1.444
INTEGER, INTENT(IN) :: ID,IM,IY ZPDATE1.445
! OUTPUT ARGUMENTS ZPDATE1.446
INTEGER, INTENT(OUT) :: OD ZPDATE1.447
ZPDATE1.448
OD = ID - 32075 ZPDATE1.449
& + 1461 * ( IY + 4800 - ( 14 - IM ) / 12 )/4 ZPDATE1.450
& + 367 * ( IM - 2 + (( 14 - IM ) / 12 ) * 12 ) / 12 ZPDATE1.451
& - 3 * ( ( IY + 4900 - ( 14 - IM ) / 12 ) / 100 ) / 4 ZPDATE1.452
ZPDATE1.453
ZPDATE1.454
END SUBROUTINE JDATE31 ZPDATE1.455
ZPDATE1.456
!----------------------------------------------------------------------- ZPDATE1.457
SUBROUTINE JDATE13(ID,OD,OM,OY) ZPDATE1.458
! ZPDATE1.459
! Returns the Day, Month, Year from a Julian Day Number ZPDATE1.460
! ZPDATE1.461
ZPDATE1.462
IMPLICIT NONE ZPDATE1.463
! INPUT ARGUMENTS ZPDATE1.464
INTEGER, INTENT(IN) :: ID ZPDATE1.465
! OUTPUT ARGUMENTS ZPDATE1.466
INTEGER, INTENT(OUT) :: OD,OM,OY ZPDATE1.467
! LOCAL VARIABLES ZPDATE1.468
INTEGER :: J,I,L,N ZPDATE1.469
ZPDATE1.470
L = ID + 68569 ZPDATE1.471
N = ( 4 * L ) / 146097 ZPDATE1.472
L = L - ( 146097 * N + 3 ) / 4 ZPDATE1.473
I = ( 4000 * ( L + 1 ) ) / 1461001 ZPDATE1.474
L = L - ( 1461 * I ) / 4 + 31 ZPDATE1.475
J = ( 80 * L ) / 2447 ZPDATE1.476
OD = L - ( 2447 * J ) / 80 ZPDATE1.477
L = J / 11 ZPDATE1.478
OM = J + 2 - ( 12 * L ) ZPDATE1.479
OY = 100 * ( N - 49 ) + I + L ZPDATE1.480
ZPDATE1.481
ZPDATE1.482
END SUBROUTINE JDATE13 ZPDATE1.483
!---------------------------------------------------------- ZPDATE1.484
*ENDIF ZPDATE1.485
ZPDATE1.486