c Program: immt3_imma_v2.f c c FUNCTION: c This program converts COADS data from immt3 format to imma c format. Each field being converted are examined for validity. c If questionable data are detected, messages are directed to c standard output (unit 6). c c PROGRAM EXECUTION: c immt3_imma < immt3_imma.in > immt3_imma.out c c where c immt3_imma.in is a file containing two lines, the input and c output path and filenames; c and immt3_imma.out is a file where diagnostic messages get c written. c c COMPILATION: c xlf -o immt3_imma immt3_imma.f c c CORRECTIONS: c 06/04/2008 (Eric Freeman) -- Corrected Relative Wind Speed(immt characters 145-147) c for knots to m/s conversion. c Multiplied m/s value by '10' to acquire correct value(e.g. account for tenths) c for imma characters 247-249. c 02/18/2009 (Eric Freeman) -- Corrected deck id in imma chars 119-121: now 926(immt) rather than 992(gts). c Set IMMA version to constant '0'.This was being referenced as 'IMMT version'. c 03/26/2009 (Eric Freeman) -- Set NID constant to blank (' '). All obs were incorrectly being flagged as VOSCLIM. c Files will now be run through marine_coadsVOSCLIM(and associated java program) to set the NID to c ' 1' if the ship is active VOSCLIM. c 12/02/2009 (Eric Freeman): c 1) SUPD (original immt record attached to end of imma record) was being truncated to 151 chars and is corrected c to 159 chars. c 2) ATTC (char 26) was being output blank and is now corrected to constant '4' (as with the NCDC imma fixed attachment structure) c 3) TI (char 27) was being output blank and is now corrected to constant '0' (hours to nearest whole hour) when hours is c present c 4) Wind speed (and relative wind speed) conversion equations taken to higher precision to correct rounding c differences between NCDC and ESRL software. Conversion equations taken from lmrlib at , funtion: 'fxktms' c 5) Based on dwpt indicators, made appropriate values negative (i.e ice bulbs and neg. wet bulbs -- these were previously c output as positive) and corrected indicators c 12/03/2009 (Eric Freeman): c 1) HDG(ships heading) and COG(course over ground) corrected to only allow values 0-360. Removed invalid translation c values 0 = 361 and 999 = 362. c 2) Corrected SP2 (secondary swell period) to only output values 0-30,99. c 3) Added code to translate 2nd Past Weather to IMMA (previously not being done). c 4) Corrected WMI (wave meas. indicator) to be blank when no wave parameters are recorded. c 12/08/2009 (Eric Freeman): c 1) Corrected cloud height and visibility indicator (hvv) to place appropriate indicators in the imma vi c and hi indicator positions c 2) Corrected LI and TI to be null when no values are recorded for associated indicators c 3) Corrected lat and long to be null when immt values are missing (for some reason these were being zero filled!) or c invalid. c 12/09/2009 (Eric Freeman): c 1) Added validity checks for various fields, including time and location. c c c character filein*80, filout*80, rin*159, rout*479, emsg*78 character tpind*1, quad*1, hvv*1, hcl*1, wndind*1, sdpt*1, & cld*1, siwork*1, swbt*1, cksw*1 c integer moda(12) logical eof7, exists, baddta, rec_ok, aok, prrec data moda /31,28,31,30,31,30,31,31,30,31,30,31/ c write (6, 20) 20 format(/'Program To Convert Marine IMMT3 Format To IMMA Format') c c READ DATA FILE NAMES c write (6, 30) 30 format(/'Enter Input Path and File') read(5, '(a)') filein c write (6, 40) 40 format(/'Enter Output Path and File') read(5, '(a)') filout c write(6, 50) filein, filout 50 format(/'File In = ',a & /'File Out = ',a) c c OPEN INPUT AND OUTPUT FILES c inquire(file=filein, exist=exists) if (exists) then open(7, file=filein, status='old') eof7 = .false. else write(6, 60) 60 format(/'ERROR - INPUT FILE NOT FOUND!!! ABORTING!!!') stop endif inrec = 0 c open(9, file=filout, status='unknown') c c CONVERT THE FORMAT c write(6, 65) 65 format(/' - IMMT3 TO COADS - DIAGNOSTIC ERROR LIST -') c do 500 while (.not. eof7) c read(7, '(a)', iostat=ios) rin if (ios .eq. 0) then inrec = inrec + 1 c elseif (ios .eq. -1) then ! END OF FILE???? eof7 = .true. go to 500 else write(6, 70) inrec, ios 70 format(//'**** ERROR - READING FROM INPUT FILE, INREC = ',i7, & ', IOS = ',i3 & /'**** ABORTING!!!!!!! ABORTING!!!!!!! ABORTING!!!!!!') close(7) close(9) stop endif prrec = .true. ! FLAG FOR ERROR PRINTING.... rec_ok = .true. c rout = ' ' c c ASSIGN CONSTANTS c rout(24:25) = ' 0' ! IMMA Version Constant (for now) rout(26:26) = '4' ! ATTC is always 4 for NCDC imma format rout(31:32) = ' ' ! NID CONSTANT rout(119:124) = '926112' ! DECK AND SID CONTANT rout(109:112) = ' 165' ! C1 attm ID and length rout(174:177) = ' 276' ! C2 attm ID and length rout(250:253) = ' 366' ! C3 attm ID and length rout(316:320) = '99 0 ' ! C6 attm ID, length, and encoding rout(321:479) = rin ! Input data (imma supplemental attm) c c TEMPERATURE INDICATOR c tpind = rin(1:1) if(rin(31:33).eq.' ' .and. rin(35:37).eq.' ' .and. & rin(51:53).eq.' ' .and. rin(90:92).eq.' ') then rout(69:69) = ' ' else if(tpind .eq. '3') then rout(69:69) = '0' ! TENTHS DEG. C elseif(tpind .eq. '4') then rout(69:69) = '1' ! HALF DEG. C elseif(tpind .eq. '5') then rout(69:69) = '2' ! WHOLE DEG. C else emsg = 'Elem 1 ( 1- 1), TEMP INDICATOR "'//rin(1:1)//'"' call pr_err(rin, emsg, prrec) endif endif c c YEAR c baddta = .false. call ckch_2(rin(2:2), baddta) call ckch_2(rin(3:3), baddta) call ckch_2(rin(4:4), baddta) call ckch_2(rin(5:5), baddta) c read(rin(2:5),'(i4)',iostat=ios) iyr c TEST FOR ERRORS if (ios .eq. 0 .and. .not. baddta) then if (rin(2:5) .eq. ' ') then rout(1:4) = ' ' elseif (iyr .ge. 1963 .and. iyr .lt. 2100) then write(rout(1:4),'(i4.4)') iyr else emsg = 'Elem 2 ( 2- 5), YEAR "'//rin(2:5)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif else emsg = 'Elem 2 ( 2- 5), YEAR "'//rin(2:5)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif c c c MONTH baddta = .false. call ckch_1(rin(6:6), baddta, cksw) call ckch_2(rin(7:7), baddta) c read(rin(6:7),'(i2)',iostat=ios) imo c TEST VALUE FOR BAD READ OR INVALID CHARS... if (ios .ne. 0 .or. baddta) then emsg='Elem 3 ( 6- 7), MONTH "'//rin(6:7)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. else if (rin(6:7) .eq. ' ') then rout(5:6) = ' ' elseif (imo .ge. 1 .and. imo .le. 12) then c c SET numda TO THE MAX DAY FOR THIS MONTH... c numda = moda(imo) if (imo .eq. 2) then if(mod(iyr,4) .eq. 0) then numda = 29 endif endif write(rout(5:6),'(i2.2)') imo else numda = 99 emsg='Elem 3 ( 6- 7), MONTH "'//rin(6:7)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c DAY baddta = .false. call ckch_1(rin(8:8), baddta, cksw) call ckch_2(rin(9:9), baddta) c read(rin(8:9),'(i2)',iostat=ios) ida if (ios .ne. 0 .or. baddta) then emsg='Elem 4 ( 8- 9), DAY "'//rin(8:9)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. else if (rin(8:9) .eq. ' ') then rout(7:8) = ' ' elseif (ida .ge. 1 .and. ida .le. 31) then write(rout(7:8),'(i2.2)') ida continue else emsg='Elem 4 ( 8- 9), DAY "'//rin(8:9)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c HOUR baddta = .false. call ckch_1(rin(10:10), baddta, cksw) call ckch_2(rin(11:11), baddta) c read(rin(10:11),'(i2)',iostat=ios) ihr if (ios .ne. 0 .or. baddta) then emsg='Elem 5 ( 10- 11), HOUR "'//rin(10:11)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. rout(27:27) = ' ' ! Set time indicator else if (rin(10:11).eq. ' ') then rout(9:12) = ' ' rout(27:27) = ' ' ! Set time indicator else ihr = ihr * 100 if (ihr .ge. 0 .and. ihr .le. 2300) then write(rout(9:12),'(i4.4)') ihr rout(27:27) = '0' ! Set time indicator continue else emsg='Elem 5 ( 10- 11), HOUR "'//rin(10:11)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif endif c c LATITUDE quad = rin(12:12) if(quad .eq. '1' .or. quad .eq. '3' .or. & quad .eq. '5' .or. quad .eq. '7') then c baddta = .false. call ckch_2(rin(13:13), baddta) call ckch_2(rin(14:14), baddta) call ckch_2(rin(15:15), baddta) c read(rin(13:15),'(i3)',iostat=ios) lat if (ios .ne. 0 .or. baddta) then emsg = 'Elem 7 ( 13- 15), LATITUDE "'//rin(13:15)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. else if (lat .ge. 0 .and. lat .le. 900) then if (quad .eq. '3' .or. quad .eq. '5') then lat = -1 * lat endif lat = lat * 10 write(rout(13:17),'(i5)') lat else emsg = 'Elem 7 ( 13- 15), LATITUDE "'//rin(13:15)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif else emsg = 'Elem 6 ( 12- 12), LAT. QUADRANT "'//rin(12:12)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif c c LONGITUDE quad = rin(12:12) if(quad .eq. '1' .or. quad .eq. '3' .or. & quad .eq. '5' .or. quad .eq. '7') then c baddta = .false. call ckch_2(rin(16:16), baddta) call ckch_2(rin(17:17), baddta) call ckch_2(rin(18:18), baddta) call ckch_2(rin(19:19), baddta) c read(rin(16:19),'(i4)',iostat=ios) lon if (ios .ne. 0 .or. baddta) then emsg = 'Elem 8 ( 16- 19), LONGITUDE "'//rin(16:19)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. else if(lon .ge. 0 .and. lon .le. 1800) then if (quad .eq. '5' .or. quad .eq. '7') then lon = -1 * lon endif lon = lon * 10 write(rout(18:23),'(i6)') lon else emsg = 'Elem 8 ( 16- 19), LONGITUDE "'//rin(16:19)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif else emsg = 'Elem 6 ( 12- 12), LONG. QUADRANT "'//rin(12:12)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif c c LATITUDE/LONGITUDE INDICATOR if(rout(13:17).eq.' ' .and. rout(18:23).eq.' ') then rout(28:28) = ' ' else rout(28:28) = '0' ! Always degrees and tenths endif c c CLOUD HT/VISIBILITY INDICATOR c if (rin(20:23).eq.' ') then if (rin(20:20).eq.' ') then emsg = 'Elem 9/10/11 ( 20- 23), IVHH = "'//rin(20:20)// & '", Ht Of Clds = "'//rin(21:21)//'", VV = "'// & rin(22:23)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. go to 120 c endif c elseif (rin(20:20).eq.' ') then c emsg = 'Elem 9/10/11 ( 20- 23), IVHH = "'//rin(20:20)// c & '", Ht Of Clds = "'//rin(21:21)//'", VV = "'// c & rin(22:23)//'"' c call pr_err(rin, emsg, prrec) c rec_ok = .false. c endif c elseif (rin(21:21).eq.' ' .and. rin(22:23).eq.' ') then rout(54:54) = ' ' rout(93:93) = ' ' elseif (rin(21:21).ne.' ' .and. rin(22:23).ne.' ') then hvv = rin(20:20) if (hvv.eq.'0') then rout(54:54) = '0' rout(93:93) = '0' elseif (hvv.eq.'1') then rout(54:54) = '0' rout(93:93) = '1' elseif (hvv.eq.'2') then rout(54:54) = '1' rout(93:93) = '1' elseif (hvv.eq.'3') then rout(54:54) = '1' rout(93:93) = '0' endif elseif (rin(21:21).ne.' ' .and. rin(22:23).eq.' ') then hvv = rin(20:20) if (hvv.eq.'0' .or. hvv.eq.'3') then rout(54:54) = ' ' rout(93:93) = '0' elseif (hvv.eq.'1' .or. hvv.eq.'2') then rout(54:54) = ' ' rout(93:93) = '1' endif elseif (rin(21:21).eq.' ' .and. rin(22:23).ne.' ') then hvv = rin(20:20) if (hvv.eq.'0' .or. hvv.eq.'1') then rout(54:54) = '0' rout(93:93) = ' ' elseif (hvv.eq.'2' .or. hvv.eq.'3') then rout(54:54) = '1' rout(93:93) = ' ' endif else emsg = 'Elem 9 ( 20- 20), IVHH "'//rin(20:20)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif c c c CLOUD HT if (rin(21:21) .ne. ' ') then hcl = rin(21:21) if((hcl.ge.'0' .and. hcl.le.'9') .or. hcl .eq. '/') then if (hcl .eq. '/') then hcl = 'A' endif rout(94:94) = hcl else c rout(94:94) = hcl emsg = 'Elem 10 ( 21- 21), CLOUD HT "'//rin(21:21)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c VISIBILITY if (rin(22:23) .ne. ' ') then read(rin(22:23),'(i2)',iostat=ios) ivv if (ios.eq. 0 .and. ivv .ge. 90 .and. ivv .le. 99)then write(rout(55:56),'(i2)') ivv else emsg = 'Elem 11 ( 22- 23), VISIBILITY "'//rin(22:23)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c CLOUD AMT 120 continue if (rin(24:24) .ne. ' ') then if (rin(24:24) .ge. '0' .and. rin(24:24) .le. '9') then rout(90:90) = rin(24:24) else c rout(90:90) = rin(24:24) emsg = 'Elem 12 ( 24- 24), CLOUD AMT "'//rin(24:24)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c WIND DIRECTION / WIND SPEED c if (rin(25:29) .eq. ' ') then c go to 160 ! DATA MISSING c endif c c aok = .true. c if (rin(25:26) .eq. ' ' .or. rin(27:27) .eq. ' ' .or. c & rin(28:29) .eq. ' ') then c aok = .false. c endif c c CONVERT WIND DIRECTION if (rin(25:26) .ne. ' ') then baddta = .false. call ckch_1(rin(25:25), baddta, cksw) call ckch_2(rin(26:26), baddta) read(rin(25:26),'(i2)',iostat=ios) iwd if (ios .ne. 0 .or. baddta) then aok = .false. elseif (iwd .gt. 0 .and. iwd .le. 36) then rout(46:46) = '0' iwd = iwd * 10 write(rout(47:49),'(i3)')iwd elseif(iwd .eq. 0) then rout(46:46) = '0' rout(47:49) = '361' elseif(iwd .eq. 99) then rout(46:46) = '0' rout(47:49) = '362' else aok = .false. endif endif c wndind = rin(27:27) ! WIND SP INDICATOR c if (rin(27:27) .ne. ' ' .and. rin(28:29) .ne. ' ') then c baddta = .false. ! CHECK WIND SPEED... call ckch_1(rin(28:28), baddta, cksw) call ckch_2(rin(29:29), baddta) read(rin(28:29),'(i2)',iostat=ios) iws if (ios .eq. 0 .and. .not. baddta .and. & iws .ge. 0 .and. iws .le. 99) then c if (wndind .eq. '0' .or. wndind .eq. '1') then rout(50:50) = wndind iws2 = iws * 10 write(rout(51:53),'(i3)') iws2 elseif(wndind .eq. '3' .or. wndind .eq. '4') then rout(50:50) = wndind iws2 = nint(float(iws) * 0.51444444444444444444 * 10.0) write(rout(51:53),'(i3)') iws2 else aok = .false. endif c else aok = .false. endif else aok = .false. endif c if (.not. aok) then emsg='Elem 13/14/15 ( 25- 29), WIND DIR = "'//rin(25:26)// & '", WS IND = "'//rin(27:27)//'", WIND SP = "'//rin(28:29)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif c 160 continue c c AIR TEMP SIGN AND AIR TEMPERATURE c CONDITIONS: TEMP SIGN MUST BE VALID, AND TEMP FIELD MUST c NOT BE EMPTY. if (rin(30:33) .ne. ' ') then c aok = .true. if (rin(30:30) .eq. ' ' .or. rin(31:33) .eq. ' ') then aok = .false. endif c if (rin(30:30) .ne. '0' .and. rin(30:30) .ne. '1') then aok = .false. endif c ! CHECK FIELD CHARACTERS baddta = .false. call ckch_1(rin(31:31), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(32:32), baddta, cksw) else call ckch_2(rin(32:32), baddta) endif call ckch_2(rin(33:33), baddta) if(baddta) then aok = .false. endif c read(rin(31:33),'(i3)',iostat=ios) itemp if (ios .eq. 0 .and. itemp .ge. 0 .and. itemp .le. 999) then continue else aok = .false. endif c if (aok) then if (rin(30:30).eq.'1') then itemp = -1 * itemp endif write(rout(70:73),'(i4)') itemp c else emsg = 'Elem 16/17 ( 30- 33), AIR SIGN = "'//rin(30:30)// & '", AIR TEMP = "'//rin(31:33)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c DEW POINT INDICATOR c DEW POINT TEMPERATURE.... if (rin(34:37) .ne. ' ') then c CHECK VALIDITY aok = .true. if (rin(34:34) .eq. ' ' .or. rin(35:37) .eq. ' ') then aok = .false. endif c sdpt = rin(34:34) if ((sdpt.eq.'0' .or. sdpt.eq.'1' .or. sdpt.eq.'2' .or. & sdpt.eq.'5' .or. sdpt.eq. '6' .or. sdpt.eq.'7')) then continue else aok = .false. endif c baddta = .false. call ckch_1(rin(35:35), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(36:36), baddta, cksw) else call ckch_2(rin(36:36), baddta) endif call ckch_2(rin(37:37), baddta) c read(rin(35:37),'(i3)', iostat=ios) idpt if (ios .eq. 0 .and. .not. baddta .and. & idpt .ge. 0 .and. idpt .le. 999) then continue else aok = .false. endif c if (aok) then if (sdpt.eq.'1' .or. sdpt.eq.'2' .or. sdpt.eq.'6' .or. & sdpt.eq.'7') then ! NEGATIVE idpt = -1 * idpt endif if (sdpt .eq. '0' .or. sdpt .eq. '1') then rout(79:79) = '0' ! MEASURED c elseif (sdpt .eq. '5' .or. sdpt .eq. '6') then rout(79:79) = '1' ! COMPUTED c elseif (sdpt .eq. '2') then rout(79:79) = '2' ! ICED MEASURED c else ! sdpt = 7 rout(79:79) = '3' ! ICED COMPUTED endif write(rout(80:83),'(i4)') idpt c else emsg = 'Elem 18/19 ( 34- 37), DEW PT SIGN = "'//rin(34:34)// & '", DEW PT TEMP = "'//rin(35:37)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c AIR PRESSURE if (rin(38:41) .ne. ' ') then c baddta = .false. call ckch_1(rin(38:38), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(39:39), baddta, cksw) else call ckch_2(rin(39:39), baddta) endif if (cksw .eq. '1') then call ckch_1(rin(40:40), baddta, cksw) else call ckch_2(rin(40:40), baddta) endif call ckch_2(rin(41:41), baddta) c read(rin(38:41),'(i4)',iostat=ios) iapr if (ios .eq. 0 .and. .not. baddta .and. & iapr .ge. 0 .and. iapr .le. 9999) then if(iapr .lt. 5000) then iapr = 10000 + iapr endif if (iapr .lt. 8700 .or. iapr .gt. 10746) then emsg = 'Elem 20 ( 38- 41), AIR PRESSURE "'//rin(38:41)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. else write(rout(60:64),'(i5)') iapr endif else emsg = 'Elem 20 ( 38- 41), AIR PRESSURE "'//rin(38:41)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c PRESENT WEATHER if (rin(42:43) .ne. ' ') then c baddta = .false. call ckch_1(rin(42:42), baddta, cksw) call ckch_2(rin(43:43), baddta) read(rin(42:43),'(i2)',iostat=ios) ipw if(ios .eq. 0 .and. .not. baddta .and. & ipw .ge. 0 .and. ipw .le. 99) then write (rout(57:58),'(i2)') ipw else emsg = 'Elem 21 ( 42- 43), PRESENT WEA "'//rin(42:43)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c PAST WEATHER if (rin(44:44) .ne. ' ') then if (rin(44:44).ge.'0' .and. rin(44:44).le.'9') then rout(59:59) = rin(44:44) else emsg = 'Elem 22 ( 44- 44), PAST WEATHER "'//rin(44:44)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c 2nd PAST WEATHER if (rin(45:45) .ne. ' ') then if (rin(45:45).ge.'0' .and. rin(45:45).le.'9') then rout(183:183) = rin(45:45) else emsg = 'Elem 23 ( 45- 45), 2nd PAST WX "'//rin(45:45)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c AMT OF LOWEST CLOUDS... if (rin(46:46) .ne. ' ') then if (rin(46:46).ge.'0' .and. rin(46:46).le.'9') then rout(91:91) = rin(46:46) else emsg = 'Elem 24 ( 46- 46), Nh "'//rin(46:46)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c LOW CLOUDS if (rin(47:47) .ne. ' ') then cld = rin(47:47) if((cld.ge.'0' .and. cld.le.'9') .or. cld .eq. '/') then if (cld .eq. '/') then cld = 'A' endif rout(92:92) = cld else emsg = 'Elem 25 ( 47- 47), Cl "'//rin(47:47)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c MID CLOUDS if (rin(48:48) .ne. ' ') then cld = rin(48:48) if((cld.ge.'0' .and. cld.le.'9') .or. cld .eq. '/') then if (cld .eq. '/') then cld = 'A' endif rout(95:95) = cld else emsg = 'Elem 26 ( 48- 48), Cm "'//rin(48:48)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c HIGH CLOUDS if (rin(49:49) .ne. ' ') then cld = rin(49:49) if((cld.ge.'0' .and. cld.le.'9') .or. cld .eq. '/') then if (cld .eq. '/') then cld = 'A' endif rout(96:96) = cld else emsg = 'Elem 27 ( 49- 49), Ch "'//rin(49:49)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SEA SFC TEMP SIGN AND SEA SFC TEMPERATURE c CONDITIONS: TEMP SIGN MUST BE VALID, AND TEMP FIELD MUST c NOT BE EMPTY. if (rin(50:53) .ne. ' ') then c aok = .true. if (rin(50:50) .eq. ' ' .or. rin(51:53) .eq. ' ') then aok = .false. endif c if (rin(50:50).ne.'0' .and. rin(50:50).ne.'1') then aok = .false. endif c baddta = .false. call ckch_1(rin(51:51), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(52:52), baddta, cksw) else call ckch_2(rin(52:52), baddta) endif call ckch_2(rin(53:53), baddta) c read(rin(51:53),'(i3)',iostat=ios) itemp if (ios .eq. 0 .and. .not. baddta .and. & itemp .ge. 0 .and. itemp .le. 999) then continue else aok = .false. endif c if (aok) then if (rin(50:50).eq.'1') then itemp = -1 * itemp endif write(rout(86:89),'(i4)') itemp c else emsg = 'Elem 28/29 ( 50- 53), S-S SIGN = "'//rin(50:50)// & '", S-S TEMP = "'//rin(51:53)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c c SEA SFC TEMP MEASUREMENT INDICATOR (0 - 7 VALID) if (rin(51:53).eq.' ') then rout(84:85) = ' ' else if (rin(54:54) .ne. ' ') then if (rin(54:54) .ge. '0' .and. rin(54:54) .le. '7') then rout(84:84) = ' ' rout(85:85) = rin(54:54) else emsg = 'Elem 30 ( 54- 54), S-S TEMP IND "'//rin(54:54)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif endif c c WAVE MEASUREMENT INDICATOR (0 - 9 VALID) if (rin(56:65).eq.' ' .and. & rin(99:104).eq.' ') then rout(188:188) = ' ' else if (rin(55:55) .ne. ' ') then if (rin(55:55) .ge. '0' .and. rin(55:55) .le. '9') then rout(188:188) = rin(55:55) else emsg = 'Elem 30 ( 55- 55), WAVE IND "'//rin(55:55)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif endif c c WAVE PERIOD if (rin(56:57) .ne. ' ') then c baddta = .false. call ckch_1(rin(56:56), baddta, cksw) call ckch_2(rin(57:57), baddta) c read(rin(56:57),'(i2)',iostat=ios) iwp aok = .true. if (ios .ne. 0 .or. baddta) then aok = .false. elseif ((iwp .ge. 0 .and. iwp .le. 30) .or. iwp .eq. 99) then continue else aok = .false. endif c if (aok) then write(rout(99:100),'(i2)') iwp else emsg = 'Elem 32 ( 56- 57), WAVE PERIOD "'//rin(56:57)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c WAVE HEIGHT if (rin(58:59) .ne. ' ') then c baddta = .false. call ckch_1(rin(58:58), baddta, cksw) call ckch_2(rin(59:59), baddta) c read(rin(58:59),'(i2)',iostat=ios) iwh if (ios.eq.0 .and. .not. baddta .and. & iwh.ge.0 .and. iwh.le.99) then write(rout(101:102),'(i2)') iwh else emsg = 'Elem 33 ( 58- 59), WAVE HEIGHT "'//rin(58:59)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SWELL DIRECTION if (rin(60:61) .ne. ' ') then c baddta = .false. call ckch_1(rin(60:60), baddta, cksw) call ckch_2(rin(61:61), baddta) c read(rin(60:61),'(i2)',iostat=ios) isd aok = .true. if (ios .ne. 0 .or. baddta) then aok = .false. elseif ((isd .ge. 0 .and. isd .le. 36) .or. isd .eq. 99) then continue else aok = .false. endif c if (aok) then if (isd .eq. 99) then isd = 38 endif write(rout(103:104),'(i2)') isd else emsg = 'Elem 34 ( 60- 61), SWELL DIR. "'//rin(60:61)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SWELL PERIOD if (rin(62:63) .ne. ' ') then c baddta = .false. call ckch_1(rin(62:62), baddta, cksw) call ckch_2(rin(63:63), baddta) c aok = .true. read(rin(62:63),'(i2)',iostat=ios) isp if (ios .ne. 0 .or. baddta) then aok = .false. elseif ((isp .ge. 0 .and. isp .le. 30) .or. isp .eq. 99) then continue else aok = .false. endif c if (aok) then write(rout(105:106),'(i2)') isp else emsg = 'Elem 35 ( 62- 63), SWELL PERIOD "'//rin(62:63)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SWELL HEIGHT if (rin(64:65) .ne. ' ') then c baddta = .false. call ckch_1(rin(64:64), baddta, cksw) call ckch_2(rin(65:65), baddta) c read(rin(64:65),'(i2)',iostat=ios) ish if (ios .eq. 0 .and. .not. baddta .and. & ish .ge. 0 .and. ish .le. 99) then write(rout(107:108),'(i2)') ish else emsg = 'Elem 36 ( 64- 65), SWELL HEIGHT "'//rin(64:65)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c ICE ACCRETION ON SHIP if (rin(66:66) .ne. ' ') then if (rin(66:66).ge.'1' .and. rin(66:66).le.'5') then rout(195:195) = rin(66:66) else emsg = 'Elem 37 ( 66- 66), ICE ACCRETION "'//rin(66:66)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c THICKNESS OF ICE if (rin(67:68) .ne. ' ') then c baddta = .false. call ckch_1(rin(67:67), baddta, cksw) call ckch_2(rin(68:68), baddta) c read(rin(67:68),'(i2)',iostat=ios) icet if (ios .eq. 0 .and. .not. baddta .and. & icet .ge. 0 .and. icet .le. 99) then write(rout(196:197),'(i2)') icet else emsg = 'Elem 38 ( 67- 68), ICE THICKNESS "'//rin(67:68)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c ICE ACCRETION RATE if (rin(69:69) .ne. ' ') then if (rin(69:69).ge.'0' .and. rin(69:69).le.'4') then rout(198:198) = rin(69:69) else emsg = 'Elem 39 ( 69- 69), ICE ACC. RATE "'//rin(69:69)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c OBSERVATION SOURCE if (rin(70:70) .ne. ' ') then if (rin(70:70).ge.'0' .and. rin(70:70).le.'6') then rout(178:178) = rin(70:70) else emsg = 'Elem 40 ( 70- 70), OB. SOURCE "'//rin(70:70)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c OBSERVATION PLATFORM if (rin(71:71) .ne. ' ') then if (rin(71:71).ge.'0' .and. rin(71:71).le.'9') then rout(179:179) = rin(71:71) else emsg = 'Elem 41 ( 71- 71), OB. PLATFORM "'//rin(71:71)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SHIP IDENTIFIER rout(35:41) = rin(72:78) c c COUNTRY CODE rout(44:45) = rin(79:80) c c QUALITY CONTROL INDICATOR if (rin(82:82) .ne. ' ') then if (rin(82:82).ge.'0' .and. rin(82:82).le.'9') then rout(209:209) = rin(82:82) else emsg = 'Elem 45 ( 82- 82), QC INDICATOR "'//rin(82:82)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c WEATHER DATA INDICATOR if (rin(83:83) .ne. ' ') then if (rin(83:83).eq.'1' .or. rin(83:83).eq.'4' .or. & rin(83:83).eq.'7') then rout(182:182) = rin(83:83) else emsg = 'Elem 46 ( 83- 83), WEA DATA IND. "'//rin(83:83)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c INDICATOR FOR PRECIP DATA if (rin(84:84) .ne. ' ') then if (rin(84:84).ge.'0' .and. rin(84:84).le.'4') then rout(204:204) = rin(84:84) else emsg = 'Elem 47 ( 84- 84), IND FOR PRECIP "'//rin(84:84)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c AMOUNT OF PRECIP AND DURATION if (rin(85:88) .ne. ' ') then c CHECK VALIDITY baddta = .false. call ckch_1(rin(85:85), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(86:86), baddta, cksw) else call ckch_2(rin(86:86), baddta) endif call ckch_2(rin(87:87), baddta) c aok = .true. if (rin(85:87) .ne. ' ') then read(rin(85:87),'(i3)',iostat=ios) ipcp if (ios .eq. 0 .and. .not. baddta .and. & ipcp .ge. 0 .and. ipcp .le. 999) then write(rout(205:207),'(i3)') ipcp else aok = .false. endif endif c if (rin(88:88) .ne. ' ') then if (rin(88:88).ge.'1' .and. rin(88:88).le.'9') then rout(208:208) = rin(88:88) else aok = .false. endif endif c if (.not. aok) then emsg = 'Elem 48/49 ( 85- 88), AMT PRCP = "'//rin(85:87)// & '", DUR OF PRCP = "'//rin(88:88)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c WET BULB INDICATOR c WET BULB TEMPERATURE.... if (rin(89:92) .ne. ' ') then c CHECK VALIDITY aok = .true. if (rin(89:89) .eq. ' ' .or. rin(90:92) .eq. ' ')then aok = .false. endif c swbt = rin(89:89) if ((swbt.eq.'0' .or. swbt.eq.'1' .or. swbt.eq.'2' .or. & swbt.eq.'5' .or. swbt.eq. '6' .or. swbt.eq.'7')) then continue else aok = .false. endif c if (rin (90:92) .ne. ' ') then baddta = .false. call ckch_1(rin(90:90), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(91:91), baddta, cksw) else call ckch_2(rin(91:91), baddta) endif call ckch_2(rin(92:92), baddta) c read(rin(90:92),'(i3)', iostat=ios) iwbt if (ios .eq. 0 .and. .not. baddta .and. & iwbt .ge. 0 .and. iwbt .le. 999) then continue else aok = .false. endif endif c if (aok) then if (swbt.eq.'1' .or. swbt.eq.'2' .or. swbt.eq.'6' & .or. swbt.eq.'7') then ! NEGATIVE iwbt = -1 * iwbt endif if (swbt .eq. '0' .or. swbt .eq. '1') then rout(74:74) = '0' ! MEASURED c elseif (swbt .eq. '5' .or. swbt .eq. '6') then rout(74:74) = '1' ! COMPUTED c elseif (swbt .eq. '2') then rout(74:74) = '2' ! ICED MEASURED c else ! swbt = 7 rout(74:74) = '3' ! ICED COMPUTED endif write(rout(75:78),'(i4)') iwbt c else emsg = 'Elem 50/51 ( 89- 92), WB SIGN = "'//rin(89:89)// & '", WB TEMP = "'//rin(90:92)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c CHARACTERISTIC OF PRESS. TENDENCY c PRESSURE TENDENCY if (rin(93:96) .ne. ' ') then aok = .true. c if (rin(93:93) .eq. ' ' .and. rin(94:96) .ne. ' ') then aok = .false. endif c if (rin(93:93) .ne. ' ')then if (rin(93:93).ge.'0' .and. rin(93:93).le.'8') then rout(65:65) = rin(93:93) else aok = .false. endif endif c if (rin(94:96) .ne. ' ') then baddta = .false. call ckch_1(rin(94:94), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(95:95), baddta, cksw) else call ckch_2(rin(95:95), baddta) endif call ckch_2(rin(96:96), baddta) c read(rin(94:96),'(i3)',iostat=ios) iptnd if (ios .eq. 0 .and. .not. baddta .and. & iptnd .ge. 0 .and. iptnd .le. 510) then write(rout(66:68),'(i3)') iptnd else aok = .false. endif endif c if (.not. aok) then emsg = 'Elem 52/53 ( 93- 96), PR TEND CHAR = "'//rin(93:93)// & '", PRESS TEND = "'//rin(94:96)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SHIP COURSE if (rin(97:97) .ne. ' ') then if (rin(97:97).ge.'0' .and. rin(97:97).le.'9') then rout(29:29) = rin(97:97) else emsg = 'Elem 54 ( 97- 97), SHIP COURSE "'//rin(97:97)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SHIP SPEED if (rin(98:98) .ne. ' ') then if (rin(98:98).ge.'0' .and. rin(98:98).le.'9') then rout(30:30) = rin(98:98) else emsg = 'Elem 55 ( 98- 98), SHIP SPEED "'//rin(98:98)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SECONDARY SWELL DIRECTION if (rin(99:100) .ne. ' ') then aok = .true. c ! CHECK VALIDITY baddta = .false. call ckch_1(rin(99:99), baddta, cksw) call ckch_2(rin(100:100), baddta) c read(rin(99:100),'(i2)',iostat=ios) issd if (ios .ne. 0 .or. baddta) then aok = .false. elseif((issd .ge. 0 .and. issd .le. 36) .or. issd .eq. 99) then continue else aok = .false. endif c if (aok) then if (issd .eq. 99) then issd = 38 endif write(rout(189:190),'(i2)') issd else emsg = 'Elem 56 ( 99-100), 2ND SWELL DIR "'//rin(99:100)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SECONDARY SWELL PERIOD if (rin(101:102) .ne. ' ') then baddta = .false. call ckch_1(rin(101:101), baddta, cksw) call ckch_2(rin(102:102), baddta) c aok = .true. read(rin(101:102),'(i2)',iostat=ios) issp if (ios .ne. 0 .or. baddta) then aok = .false. elseif((issp .ge. 0 .and. issp .le. 30) .or. issp .eq. 99) then continue else aok = .false. endif c if (aok) then write(rout(191:192),'(i2)') issp else emsg='Elem 57 (101-102), 2ND WAVE PERD "'//rin(101:102)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SECONDARY SWELL HEIGHT if (rin(103:104) .ne. ' ') then baddta = .false. call ckch_1(rin(103:103), baddta, cksw) call ckch_2(rin(104:104), baddta) read(rin(103:104),'(i2)',iostat=ios) issh if (ios .eq. 0 .and. .not. baddta .and. & issh .ge. 0 .and. issh .le. 99) then write(rout(193:194),'(i2)') issh else emsg='Elem 58 (103-104), 2ND WAVE HT "'//rin(103:104)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c CONCENTRATION OF SEA ICE if (rin(105:105) .ne. ' ') then siwork = rin(105:105) if((siwork.ge.'0' .and. siwork.le.'9') .or. siwork.eq.'/') then if (siwork .eq. '/') then siwork = 'A' endif rout(199:199) = siwork else emsg='Elem 59 (105-105), CONC. SEA ICE "'//rin(105:105)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c STAGE OF DEVELOPMENT if (rin(106:106) .ne. ' ') then siwork = rin(106:106) if((siwork.ge.'0' .and. siwork.le.'9') .or. siwork.eq.'/') then if (siwork .eq. '/') then siwork = 'A' endif rout(200:200) = siwork else emsg='Elem 60 (106-106), STAGE OF DEV. "'//rin(106:106)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c ICE OF LAND ORIGIN if (rin(107:107) .ne. ' ') then siwork = rin(107:107) if((siwork.ge.'0' .and. siwork.le.'9') .or. siwork.eq.'/') then if (siwork .eq. '/') then siwork = 'A' endif rout(201:201) = siwork else emsg='Elem 61 (107-107), ICE OF LAND ORIG "'//rin(107:107)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c TRUE BEARING OF PRINCIPLE ICE EDGE if (rin(108:108) .ne. ' ') then siwork = rin(108:108) if((siwork.ge.'0' .and. siwork.le.'9') .or. siwork.eq.'/') then if (siwork .eq. '/') then siwork = 'A' endif rout(202:202) = siwork else emsg='Elem 62 (108-108), ICE EDGE BEARING "'//rin(108:108)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c ICE SITUATION/TREND if (rin(109:109) .ne. ' ') then siwork = rin(109:109) if((siwork.ge.'0' .and. siwork.le.'9') .or. siwork.eq.'/') then if (siwork .eq. '/') then siwork = 'A' endif rout(203:203) = siwork else emsg='Elem 63 (109-109), ICE SITUATION "'//rin(109:109)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c FM 13 CODE VERSION if (rin(110:110) .ne. ' ') then if(rin(110:110).ge.'0' .and. rin(110:110).le.'8') then rout(180:180) = ' ' rout(181:181) = rin(110:110) else emsg='Elem 64 (110-110), FM13 CODE VER. "'//rin(110:110)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c QC INDICATORS do iq=1, 21 iqi = 111+iq iqo = 209+iq if (rin(iqi:iqi) .ne. ' ') then if(rin(iqi:iqi).ge.'0' .and. rin(iqi:iqi).le.'9') then rout(iqo:iqo) = rin(iqi:iqi) else write(emsg, 300) iq+65, iqi, iqi, iq, rin(iqi:iqi) 300 format('Elem ',i2,' ','(',i3,'-',i3,'), QC ',i2, & ' "', a1,'"') call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif enddo c c SHIPS HEADING if (rin(133:135) .ne. ' ') then baddta = .false. call ckch_1(rin(133:133), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(134:134), baddta, cksw) else call ckch_2(rin(134:134), baddta) endif call ckch_2(rin(135:135), baddta) c read(rin(133:135),'(i3)',iostat=ios) ihdg if (ios .eq. 0 .and. .not. baddta .and. & ((ihdg .ge. 0 .and. ihdg .le. 360))) then if (ihdg .eq. 0 .or. ihdg .eq. 000) then ihdg = 0 c elseif (ihdg .eq. 999) then c ihdg = endif write(rout(231:233),'(i3)') ihdg else emsg='Elem 87 (133-135), SHIP HEADING "'//rin(133:135)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c COURSE OVER GROUND if (rin(136:138) .ne. ' ') then baddta = .false. call ckch_1(rin(136:136), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(137:137), baddta, cksw) else call ckch_2(rin(137:137), baddta) endif call ckch_2(rin(138:138), baddta) c read(rin(136:138),'(i3)',iostat=ios) icog if (ios .eq. 0 .and. .not. baddta .and. & ((icog .ge. 0 .and. icog .le. 360))) then if (icog .eq. 0 .or. icog .eq. 000) then icog = 0 c elseif (icog .eq. 999) then c icog = ' ' endif write(rout(234:236),'(i3)') icog else emsg='Elem 88 (136-138), C. O. G. "'//rin(136:138)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c SHIPS SPEED if (rin(139:140) .ne. ' ') then call ckch_1(rin(139:139), baddta, cksw) call ckch_2(rin(140:140), baddta) read(rin(139:140),'(i2)',iostat=ios) isog if (ios .eq. 0 .and. .not. baddta .and. & isog .ge. 0 .and. isog .le. 99) then write(rout(237:238),'(i2)') isog else emsg='Elem 89 (139-140), SPD OVER GRND "'//rin(139:140)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c MAX HT > SUM LOAD LINE if (rin(141:142) .ne. ' ') then call ckch_1(rin(141:141), baddta, cksw) call ckch_2(rin(142:142), baddta) read(rin(141:142),'(i2)',iostat=ios) isll if (ios .eq. 0 .and. .not. baddta .and. & isll .ge. 0 .and. isll .le. 99) then write(rout(239:240),'(i2)') isll else emsg='Elem 90 (141-142), MAX HT > SUM LL "'//rin(141:142)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c DEPARTURE OF LOAD LINE if (rin(143:145) .ne. ' ') then aok = .true. ! CHECK VALIDITY c if (rin(143:143) .eq. ' ' .or. rin(144:145) .eq. ' ') then aok = .false. endif c if (rin(143:143).ne.'0' .and. rin(143:143).ne.'1') then aok = .false. endif c read(rin(144:145),'(i2)',iostat=ios) idll if (ios .eq. 0 .and. .not. baddta .and. & idll .ge. 0 .and. idll .le. 99) then continue else aok = .false. endif c if (aok) then if (rin(143:143).eq.'1') then idll = -1 * idll endif write(rout(241:243),'(i3)') idll else emsg='Elem 91 (143-145), DEP OF REF LVL "'//rin(143:145)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c c RELATIVE WIND DIRECTION if (rin(146:148) .ne. ' ') then aok = .true. if (rin(146:148).eq.' ') then ! .or. rin(149:151).eq.' ') then aok = .false. endif c if (rin(146:148).ne.' ') then c baddta = .false. call ckch_1(rin(146:146), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(147:147), baddta, cksw) else call ckch_2(rin(147:147), baddta) endif call ckch_2(rin(148:148), baddta) c read(rin(146:148),'(i3)',iostat=ios) irwd if (ios .eq. 0 .and. .not. baddta .and. & ((irwd.ge.0 .and. irwd.le.360) .or. irwd.eq.999))then if(irwd .eq. 0) then irwd = 361 elseif(irwd .eq. 999) then irwd = 362 endif write(rout(244:246),'(i3)')irwd c else aok = .false. endif endif endif c c RELATIVE WIND SPEED if (rin(149:151) .ne. ' ' .and. rin(27:27) .ne. ' ') then wndind = rin(27:27) if (wndind .lt. '0' .or. wndind .gt. '4') then aok = .false. endif c c baddta = .false. call ckch_1(rin(149:149), baddta, cksw) if (cksw .eq. '1') then call ckch_1(rin(150:150), baddta, cksw) else call ckch_2(rin(150:150), baddta) endif call ckch_2(rin(151:151), baddta) c aok = .true. read(rin(149:151),'(i3)',iostat=ios) irws if (ios .eq. 0 .and. .not. baddta) then !.and. & irws .ge. 0 .and. irws .le. 999) then if (wndind .eq. '0' .or. wndind .eq. '1') then rout(50:50) = wndind irws2 = irws * 10 elseif(wndind .eq. '3' .or. wndind .eq. '4') then rout(50:50) = wndind irws2 = nint(float(irws) * 0.51444444444444444444 * 10.0) else irws2 = irws * 10 endif write(rout(247:249),'(i3)') irws2 else aok = .false. endif if (.not. aok) then emsg='Elem 92/14/93 (146-148,27,149-151), REL WD= "'// & rin(146:148)//'", WS IND= "'//rin(27:27)// & '", REL WS= "'//rin(149:151)//'"' call pr_err(rin, emsg, prrec) rec_ok = .false. endif endif c endif c write(9, '(a)') rout c 500 continue c write (6, 520) inrec 520 format(/'END OF PROCESSING, ',i6,' RECORDS PROCESSED') close(7) close(9) stop end c c============================================== c============================================== c subroutine pr_err(rin, emsg, prrec) c c WRITE DATA RECORD AND ERROR MESSAGE. SET LOGICAL FLAGS. c character*(*) rin, emsg logical prrec c if (prrec) then write(6, 90) 90 format(/'----------------------------------------', & '----------------------------------------' & /' 1111111111222222222233333333334', & '4444444445555555555666666666677777777778' & /'1234567890123456789012345678901234567890', & '1234567890123456789012345678901234567890' & /'----------------------------------------', & '----------------------------------------') write(6, 100) rin(1:80) write(6, 110) rin(81:159) 100 format(a) 110 format(a) prrec = .false. endif write(6, *)emsg c return end c============================================== c subroutine ckch_1(chr, baddta, cksw) c character*1 chr, cksw logical baddta c if (chr .eq. ' ') then cksw = '1' elseif (chr .ge. '0' .and. chr .le. '9') then cksw = '2' else baddta = .true. endif c return end c================================================ c subroutine ckch_2(chr, baddta) c character*1 chr logical baddta c if (chr .ge. '0' .and. chr .le. '9') then return else baddta = .true. endif c return end c================================================