|
|
C $Id: dater.f 3304 2011-01-17 15:25:59Z brideout $
|
|
|
C
|
|
|
SUBROUTINE DATER(DATE,NCHAR,DAY,MONTH,YEAR,IER)
|
|
|
C
|
|
|
C SUBROUTINES DATER, MONAME, MONUM, WKNAME, IDAY, CALNDR, JDAY,
|
|
|
C JDATER, IZLR, IDMYCK AND DATES COMPRISE A COMPREHENSIVE DATE
|
|
|
C MANIPULATION
|
|
|
C PACKAGE. THE FOLLOWING VARIABLES APPEAR IN THE CALLING SEQUENCE
|
|
|
C OF ONE OR MORE SUBROUTINES. ALL ARE TYPED INTEGER. THE VALUE
|
|
|
C CORRESPONDING TO MARCH 1, 1977 IS SHOWN IN PARENTHESES.
|
|
|
C
|
|
|
C DAY - DAY OF THE MONTH (1)
|
|
|
C MONTH - MONTH NUMBER (3)
|
|
|
C YEAR - YEAR (1977)
|
|
|
C DAYNO - DAY OF THE YEAR (60)
|
|
|
C JDAYNO - JULIAN DAY NUMBER (2443204)
|
|
|
C WDAY - WEEKDAY NUMBER (3)
|
|
|
C DATE - DATE AS A STRING OF ALPHANUMERIC CHARS, 3 CHARS/WORD.
|
|
|
C WHEN AN INPUT VARIABLE, DATE MAY BE IN ANY REASONABLE
|
|
|
C FORMAT, E.G. MARCH 1 1977, 3/1/77, ETC. IF EXPRESSED
|
|
|
C AS THREE NUMERIC FIELDS, ORDER IS PRESUMED TO BE
|
|
|
C MONTH, DAY, YEAR. WHEN AN OUTPUT VARIABLE, THE FORMAT
|
|
|
C IS DETERMINED BY IOPT, AND SIX WORDS SHOULD BE
|
|
|
C RESERVED IN THE CALLING PROGRAM.
|
|
|
C
|
|
|
C MSTR - MONTH, AS A STRING OF UPPER CASE ALPHABETIC
|
|
|
C CHARACTERS, 3 CHARACTERS/WORD. THREE WORDS SHOULD BE
|
|
|
C RESERVED IN THE CALLING PROGRAM. (MARCH)
|
|
|
C WSTR - DAY OF THE WEEK, AS A STRING OF UPPER CASE ALPHABETIC
|
|
|
C CHARACTERS, 3 CHARACTERS/WORD. THREE WORDS SHOULD BE
|
|
|
C RESERVED IN THE CALLING PROGRAM. (TUESDAY)
|
|
|
C IOPT - FORMAT INDICATOR WHEN DATE IS AN OUTPUT VARIABLE
|
|
|
C 1 - 03/01/77
|
|
|
C 3 - 01,MAR,1977
|
|
|
C 4 - 1 MARCH, 1977
|
|
|
C 5 - MARCH 1, 1977
|
|
|
C NCHAR - NUMBER OF CHARACTERS TO BE SCANNED IN AN INPUT STRING.
|
|
|
C IER - ERROR INDICATOR. IER IS RETURNED BY ALL ROUTINES IN
|
|
|
C THE PACKAGE. IER=0 IF NO ERRORS ARE DETECTED. IER=1
|
|
|
C IF AN ERROR IS DETECTED.
|
|
|
C
|
|
|
C .. Scalar Arguments ..
|
|
|
INTEGER DAY,IER,MONTH,NCHAR,YEAR
|
|
|
CHARACTER*(*) DATE
|
|
|
C ..
|
|
|
C .. Local Scalars ..
|
|
|
INTEGER I,IA,ICH,IFLAST,IOS,J,JCHAR,MCHAR,N,NA,NI
|
|
|
CHARACTER*4 CFMT
|
|
|
CHARACTER*9 ITEMP
|
|
|
CHARACTER*12 NUMER
|
|
|
CHARACTER*27 IALPH
|
|
|
C ..
|
|
|
C .. Local Arrays ..
|
|
|
INTEGER IFIELD(4,3),IT(3)
|
|
|
C ..
|
|
|
C .. External Functions ..
|
|
|
INTEGER IDMYCK
|
|
|
EXTERNAL IDMYCK
|
|
|
C ..
|
|
|
C .. External Subroutines ..
|
|
|
EXTERNAL MONUM
|
|
|
C ..
|
|
|
C .. Intrinsic Functions ..
|
|
|
INTRINSIC CHAR,ICHAR,MIN0
|
|
|
C ..
|
|
|
C .. Data statements ..
|
|
|
DATA IALPH/'ABCDEFGHIJKLMNOPQRSTUVWXYZ '/
|
|
|
DATA NUMER/'0123456789 '/
|
|
|
DATA CFMT/'(I )'/
|
|
|
C ..
|
|
|
IER = 0
|
|
|
IA = 0
|
|
|
IOS = 0
|
|
|
C .....DETERMINE FIRST THREE ALPHANUMERIC FIELDS.....
|
|
|
N = 1
|
|
|
IFLAST = 3
|
|
|
DO 40 I = 1,NCHAR + 1
|
|
|
IF (I.EQ.NCHAR+1) GO TO 30
|
|
|
DO 10 J = 1,10
|
|
|
IF (DATE(I:I).NE.NUMER(J:J)) GO TO 10
|
|
|
IF (IFLAST.EQ.1) GO TO 40
|
|
|
IF (N.GT.3) THEN
|
|
|
IER = 1
|
|
|
RETURN
|
|
|
END IF
|
|
|
IFIELD(1,N) = 1
|
|
|
IFIELD(2,N) = I
|
|
|
IF (IFLAST.NE.3 .AND. N.GT.1) IFIELD(3,N-1) = I - 1
|
|
|
IFLAST = 1
|
|
|
N = N + 1
|
|
|
GO TO 30
|
|
|
10 CONTINUE
|
|
|
C .....ALPHABETIC FIELDS.....
|
|
|
DO 20 J = 1,26
|
|
|
C IF (DATE(I:I).NE.IALPH(J:J)) GO TO 30
|
|
|
IF (DATE(I:I).NE.IALPH(J:J) .AND.
|
|
|
* CHAR(ICHAR(DATE(I:I))-32).NE.IALPH(J:J)) GO TO 20
|
|
|
IF (IFLAST.EQ.2) GO TO 40
|
|
|
IF (N.GT.3) THEN
|
|
|
IER = 1
|
|
|
RETURN
|
|
|
END IF
|
|
|
IFIELD(1,N) = 2
|
|
|
IFIELD(2,N) = I
|
|
|
IF (IFLAST.NE.3 .AND. N.GT.1) IFIELD(3,N-1) = I - 1
|
|
|
IFLAST = 2
|
|
|
N = N + 1
|
|
|
GO TO 30
|
|
|
20 CONTINUE
|
|
|
C .....OTHER FIELDS.....
|
|
|
IF (IFLAST.NE.3 .AND. N.GT.1) IFIELD(3,N-1) = I - 1
|
|
|
IFLAST = 3
|
|
|
30 IF (N.EQ.5 .OR. N.EQ.4 .AND. IFLAST.EQ.3) GO TO 50
|
|
|
40 CONTINUE
|
|
|
IFIELD(3,3) = NCHAR
|
|
|
50 IF (N.LT.4) GO TO 160
|
|
|
C
|
|
|
NA = 0
|
|
|
NI = 0
|
|
|
DO 70 I = 1,3
|
|
|
IFIELD(4,I) = 0
|
|
|
IF (IFIELD(1,I).EQ.2) GO TO 60
|
|
|
NI = NI + 1
|
|
|
GO TO 70
|
|
|
60 NA = NA + 1
|
|
|
IA = I
|
|
|
70 CONTINUE
|
|
|
IF (NA.EQ.1) GO TO 80
|
|
|
IF (NA.EQ.0) GO TO 100
|
|
|
GO TO 160
|
|
|
C
|
|
|
80 IFIELD(4,IA) = 2
|
|
|
ICH = IFIELD(2,IA)
|
|
|
MCHAR = IFIELD(3,IA) - IFIELD(2,IA) + 1
|
|
|
MCHAR = MIN0(MCHAR,12)
|
|
|
DO 90 I = 1,MCHAR
|
|
|
JCHAR = ICH + I - 1
|
|
|
ITEMP(I:I) = DATE(JCHAR:JCHAR)
|
|
|
90 CONTINUE
|
|
|
CALL MONUM(ITEMP,MONTH,IER)
|
|
|
IF (MONTH.LT.1 .OR. MONTH.GT.12) GO TO 160
|
|
|
GO TO 110
|
|
|
C
|
|
|
100 IFIELD(4,1) = 2
|
|
|
WRITE (UNIT=CFMT(3:3),FMT='(I1)') IFIELD(3,1) - IFIELD(2,1) + 1
|
|
|
READ (UNIT=DATE(IFIELD(2,1) :IFIELD(3,1)),FMT=CFMT,
|
|
|
* IOSTAT=IOS) MONTH
|
|
|
IF (IOS.NE.0 .OR. MONTH.LT.1 .OR. MONTH.GT.12) GO TO 160
|
|
|
110 J = 0
|
|
|
DO 120 I = 1,3
|
|
|
IF (IFIELD(4,I).EQ.2) GO TO 120
|
|
|
J = J + 1
|
|
|
WRITE (UNIT=CFMT(3:3),FMT='(I1)') IFIELD(3,I) - IFIELD(2,I) + 1
|
|
|
READ (UNIT=DATE(IFIELD(2,I) :IFIELD(3,I)),FMT=CFMT,
|
|
|
* IOSTAT=IOS) IT(J)
|
|
|
120 CONTINUE
|
|
|
IF (IOS.NE.0) GO TO 160
|
|
|
IF (IT(1).GT.31 .AND. IT(2).GT.31) GO TO 160
|
|
|
IF (IT(1).LT.0 .OR. IT(2).LT.0) GO TO 160
|
|
|
IF (IT(1).EQ.0 .AND. IT(2).EQ.0) GO TO 160
|
|
|
IF (IT(1).GT.31 .AND. IT(2).LE.31) GO TO 130
|
|
|
GO TO 140
|
|
|
130 DAY = IT(2)
|
|
|
YEAR = IT(1)
|
|
|
GO TO 150
|
|
|
140 DAY = IT(1)
|
|
|
YEAR = IT(2)
|
|
|
150 IF (YEAR.GE.0 .AND. YEAR.LE.99) THEN
|
|
|
IF (YEAR.GE.50 .AND. YEAR.LE.99) THEN
|
|
|
YEAR = 1900 + YEAR
|
|
|
ELSE
|
|
|
YEAR = 2000 + YEAR
|
|
|
END IF
|
|
|
END IF
|
|
|
GO TO 170
|
|
|
160 IER = 1
|
|
|
RETURN
|
|
|
170 IER = IDMYCK(DAY,MONTH,YEAR)
|
|
|
RETURN
|
|
|
C
|
|
|
END
|
|
|
|
