c Date munger function (part of DTC) c c modified 850325, CG, to allow any of the following c d{d}/m{m}/yy, d, dd, dmm, ddmm, dmmyy, ddmmyy for D or W functions c m{m}/yy, m, mm, myy, mmyy for M c y, yy for Y c Subroutine datmun (nf) ! (line,nf) c include 'comdtc.inc' c integer nf ! Number of fields expected c byte nb, l1, l2, l3, lxx(3), work(icmln), tb6(6), 1 num(0:9) /'0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ c character*3 lch, ! for dd-mon-yy format 1 mab(12) / 'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', 2 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC'/ C integer*2 iwk(42) ! 2 chars at a time c equivalence(lch, lxx, l1), (lxx(2), l2), (lxx(3), l3), 1 (work, iwk) c c statement functions for quick binary to 2-digit bcd conversion, c and vice versa c icvtbcd(inum) = (num(imod(inum, 10)) * 256) 1 .or. num(inum/10) icvtbin(ich2) = (((ich2 .and. '7f'x) - '0') * 10) 1 + ((ich2/256) - '0') c c end statement functions c c c Initialize default values for omitted fields c ixyr = idyr ! Copy current values ixmo = idmo ! (use idate instead?) ixdy = iddy c c function: c edit a line starting with a date of form c mm/dd/yy c into one starting with a date of form c mmddyy c c also if the line starts with a date of form c dd-mmm-yy c edit back into mmddyy from that form. c Leaves whatever follows the date alone. c Added for DTC to not have to use such a crock date c format as the original; too hard to use otherwise. c if mmddyy form already exists, leave line alone. c do 1 n=1, nf * 2 ! 3 for D or W, 2 for M, 1 for Y c l1 = line(n) ! Copy current character if (l1 .eq. '/') go to 100 c 100 is for mm/dd/yy form c if (l1 .eq. '-') go to 200 c 200 is for dd-mmm-yy form c if ((l1 .eq. ':') .or. (l1 .eq. '>')) go to 290 ! Hour stuff for D c 290 for hour-string first, insert current day c if ((l1 .lt. '0') .or. (l1 .gt. '9')) go to 300 c 300 mmddyy, minus some characters, fake whatever is required c work(n) = l1 ! Don't recopy c 1 continue c c if format looks OK already, just return and leave line alone. Return c 100 continue ! Assumes 'n' = 2 or 3 c handle mm/dd/yy and turn into mmddyy c if(line(2).eq.'/') then work(1)='0' work(2)=line(1) k=3 else work(1)=line(1) work(2)=line(2) k=4 end if c if ((line(k+1) .lt. '0') .or. (line(k+1) .gt. '9')) then work(3)='0' work(4)=line(k) kk=k+2 else work(3)=line(k) work(4)=line(k+1) kk=k+3 end if c if (line(kk-1) .eq. '/') then work(5)=line(kk) ! Copy (assumed) 2-digit year work(6)=line(kk+1) kkk=kk+2 else iwk(3) = icvtbcd(ixyr) ! Create a year value kkk=kk end if c c Pointers to next element of line (i.e., kkk) are now set up c for copy of rest of stuff. c go to 900 c 200 continue ! Assumes 'n' = 2 or 3 c handle dd-mmm-yy and turn into mmddyy if(line(2).eq.'-')then work(3)='0' work(4)=line(1) k=3 else work(3)=line(1) work(4)=line(2) k=4 end if c if (line(k+3) .eq. '-') then work(5)=line(k+4) ! Assume the user typed yy work(6)=line(k+5) ! after 2nd dash kkk=k+6 else iwk(3) = icvtbcd(ixyr) ! Fudge the year kkk = k+3 ! and where to start copying end if c c now have pointers, but month needs to be filled in. c note we assume year always is entered as 2 digits c and month is 3 chars... c c if(line(k+3).ne.'-')then c c zero stuff to pass if not 3 char month c c work(1)=0 c work(2)=0 c go to 900 c end if c kk=k+3 iii = 0 do 220 n=k,kk nb=line(n) c mask off 32 (dec) bit to c make letters uppercase nb = nb .and. '5f'x !223 line(n)=nb iii = iii + 1 lxx(iii) = nb 220 continue c c *** l1=line(k) c *** l2=line(k+1) c *** l3=line(k+2) c *** work(1)='0' c *** work(2)='0' c c decode months the hard way !!! You said it !!! c c *** IF(L1.EQ.'J'.AND.L2.EQ.'A')THEN c *** WORK(2)='1' c *** ELSE IF(L1.EQ.'F')THEN c *** WORK(2)='2' c *** ELSE IF(L1.EQ.'M'.AND.L2.EQ.'A'.AND.L3.EQ.'R')THEN c *** WORK(2)='3' c *** ELSE IF(L1.EQ.'A'.AND.L2.EQ.'P')THEN c *** WORK(2)='4' c *** ELSE IF(L1.EQ.'M'.AND.L2.EQ.'A'.AND.L3.EQ.'Y')THEN c *** WORK(2)='5' c *** ELSE IF(L1.EQ.'J'.AND.L2.EQ.'U'.AND.L3.EQ.'N')THEN c *** WORK(2)='6' c *** ELSE IF(L1.EQ.'J'.AND.L2.EQ.'U'.AND.L3.EQ.'L')THEN c *** WORK(2)='7' c *** ELSE IF(L1.EQ.'A'.AND.L2.EQ.'U')THEN c *** WORK(2)='8' c *** ELSE IF(L1.EQ.'S')THEN c *** WORK(2)='9' c *** ELSE IF(L1.EQ.'O')THEN c *** WORK(1)='1' c *** ELSE IF(L1.EQ.'N')THEN c *** WORK(1)='1' c *** WORK(2)='1' c *** ELSE IF(L1.EQ.'D')THEN c *** WORK(1)='1' c *** WORK(2)='2' c *** ELSE c *** WORK(1)=0 c *** WORK(2)=0 C UNRECOGNIZED MONTH -- SCREW IT... c *** END IF c do 240 i = 1, 12 ! Loop over months if (lch .eq. mab(i)) go to 250 ! Exit if found 240 continue c *** WORK(1)=0 c *** WORK(2)=0 iwk(1) = '99' ! Phony month go to 900 c 250 iwk(1) = icvtbcd(i) c c work(1) = num(i/10) c work(2) = num(imod(i, 10)) c go to 900 c 290 n = 1 ! ':' found, insert day string c 300 continue ! Short string found, fix it up kkk = n ! Where to start copying c nfd = n/2 ! Number of 2-char groups found c if (imod(n, 2) .eq. 0) then ! Note: n = 5 for 4 chars found work(1) = '0' ! Force even number of characters do i = 2, n work(i) = line(i-1) ! Shift stuff over by 1 end do end if c go to (310, 320, 330) nf ! Dispatch on # expected fields go to 900 ! Bad value ??? c 310 if (nfd .eq. 0) iwk(1) = icvtbcd(ixyr) ! Add year: Y [yy] go to 900 ! End case c 320 if (nfd .eq. 0) iwk(1) = icvtbcd(ixmo) ! M {only} if (nfd .le. 1) iwk(2) = icvtbcd(ixyr) ! M mm[yy] go to 900 ! End case c 330 if (nfd .eq. 0) iwk(1) = icvtbcd(ixdy) ! empty line c if (nfd .le. 1) then ! D [mm]dd[yy] iwk(2) = iwk(1) ! Copy day of month (see above) iwk(1) = icvtbcd(ixmo) ! Generate month end if c if (nfd .le. 2) iwk(3) = icvtbcd(ixyr) ! Generate year c 900 continue ! common clean-up & return c kk = (nf*2) + 1 if (line(kkk) .gt. ' ') then ! if no separator after date string work(kk) = ' ' ! force a space in 7th position kk = kk + 1 ! Change where to start copying end if c do 910 n=kk,icmln work(n)=line(kkk) if (kkk .lt. icmln) kkk=kkk+1 910 continue c work(icmln) = "0 ! Force end of string if shifted off c do 920 n=1,icmln ! copy edited string back 920 line(n)=work(n) ! for further work c return c end