dater.f
181 lines
| 5.8 KiB
| text/x-fortran
|
FortranFixedLexer
| r0 | 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 | ||||
