PROGRAM SNDKC C C Program for converting Kansas City format soundings to GEMPAK format C C D. Blanchard 1987 Original version - for PRESTORM format C K. Howard Dec 1987 Converted to KC format C D. Blanchard Dec 1987 Numerous cosmetic and functional changes C 13 Sep 1988 Changed NT=75 to NT=100 C 28 Jun 1989 Converted to GEMPAK V4.1 C 27 Mar 1990 Added PROFS routine to retrieve missing C 3-letter station id. Fixed missing data check. C 15 Feb 1991 Changed print statements about wind types C 15 Mar 1991 Changed number of times to 50 and number of C stations to 250. Required reworking some of C the time/station calls. C 27 Aug 1993 Revised station id read because the archive C program changed. Increased NT=150. Converted C from a VAX to a portable program. Removed all C PROFS-specific calls. C 20 Sep 1993 Increased NSTN=350 C 14 Oct 1993 Removed wind options. Raob archive winds are C always in knots. C C NT: maximum number of thermodynamic levels C NPARM: number of GEMPAK parameters C PRESS: thermodynamic pressure levels C TEMP: temperature C DWPT: dewpoint C SPD: wind speed C DIR: wind direction C HGT: height of pressure level C SNDATA: packed array of sounding data C FNAME: 40-character name for data input file C PARAMETER (NT=150,NPARM=6) DIMENSION PRESS(NT),TEMP(NT),DWPT(NT),SPD(NT),DIR(NT) DIMENSION HGT(NT),SNDATA(NPARM,NT) CHARACTER FNAME*40,FILNAM*40 C CHARACTER STID*4,PARM(NPARM)*4 CHARACTER STID*8,PARM(NPARM)*4 CHARACTER DATTIM*13,DATTIM_OLD*13,IMO*3,MONTHS(12)*3 LOGICAL FIRST,PKFLG,STMFLG DATA DATTIM_OLD /'FFFFFFFFFFFFF'/ DATA FIRST,PKFLG,STMFLG /.TRUE.,.FALSE.,.FALSE./ DATA PARM /'PRES', 'TEMP', 'DWPT', 'DRCT', 'SPED', 'HGHT'/ DATA NLEV,IVERT,IFLSRC,MAXTIM,ICOORD,NSTN /0, 1, 4, 50, 0, 350/ C DATA MONTHS /'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', + 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC'/ DATA NUMSTN /0/ C*********************************************************************** C Read in file name and open the data file C WRITE(6,20) 20 FORMAT(' Enter file from which to read data: ',$) READ(5,40) FNAME 40 FORMAT(A) IF(FNAME(1:3) .EQ. ' ') CALL EXIT(0) OPEN(20,NAME=FNAME,STATUS='OLD',ERR=320) C*********************************************************************** C Ask user if winds are in m/s or 1/10's m/s C C60 WRITE(6,80) C80 FORMAT(' Enter a "1" if winds are in m/sec',/, C 1 ' "2" if winds are in 1/10''s m/s',/, C 2 ' "3" if winds are in knots: ',$) C READ (5,*) IWFLAG C IF(IWFLAG .LT. 1 .OR. IWFLAG .GT. 3) GO TO 60 IWFLAG = 3 C*********************************************************************** C Initialize arrays and counter C 100 DO 120 I=1,NT HGT(I)=0. PRESS(I)=0. TEMP(I)=0. DWPT(I)=0. SPD(I)=0. DIR(I)=0. 120 CONTINUE NLVLS = 0 C C*********************************************************************** C Read in headers containing date, number of levels, location, etc. C 140 READ(20,160,END=360)IFR,ITIME,IDY,IMO,IYR 160 FORMAT(I7,5X,I2,5X,I2,6X,A3,6X,I2) IF(IFR .NE. 254) GO TO 140 READ(20,180,END=360)IFR1,ISTAT,ID2,SLAT,SLON,IELEV,IFLG 180 FORMAT(3I7,2F7.2,2I7) READ(20,200,END=360)IFR2,IHY,IMW,IDUM2,NUMLEV,IR,IC 200 FORMAT(7I7) READ(20,220,END=360)IFR3,STID 220 FORMAT(I7,10X,A4) C C Negate longitude; store integer elevation in real elevation C SLON = -SLON ELEV = IELEV C*********************************************************************** C Using information from data header, open a GEMPAK sounding file and C write header information. C IF(FIRST) THEN WRITE(FILNAM,240) IYR,IMO,IDY,ITIME 240 FORMAT(I2, A3, 2I2.2, 'P.SND') CALL IN_BDTA(IRET) !Initialize GEMPAK block data IF(IRET .NE. 0) THEN CALL ER_WMSG('IN',IRET,' ',IERR) STOP END IF C CALL SN_CREF(FILNAM,IFLSRC,NPARM,PARM,NSTN,MAXTIM,PKFLG,ISCALE, 1 IOFSET,IBITS,STMFLG,IFLNO,IRET) IF(IRET .NE. 0) THEN CALL ER_WMSG('SN',IRET,FILNAM,IERR) STOP END IF FIRST = .FALSE. END IF C C*********************************************************************** C Write the time to the GEMPAK sounding file. C DO I=1,12 IF(IMO(1:3) .EQ. MONTHS(I)(1:3)) THEN NMON = I GOTO 270 END IF END DO C 270 WRITE(DATTIM,280) IYR,NMON,IDY,ITIME 280 FORMAT(3I2.2,'/',I2.2,'00 ') IF(DATTIM .NE. DATTIM_OLD) THEN CALL SN_ATIM(IFLNO,DATTIM,IRET) !Add a time to the file IF (IRET .NE. 0) THEN CALL ER_WMSG('SN',IRET,FILNAM,IERR) CALL EXIT(0) END IF WRITE(6,290) DATTIM 290 FORMAT(' Adding time: ',A) DATTIM_OLD = DATTIM END IF C C*********************************************************************** C Read in height, pressure, temperature, dewpoint, wind speed and C direction, and interpolation flag from the Kansas City data file C DO 300 I=1,NUMLEV-4 READ(20,200)INTERP,IPRESS0,IHGT0,ITEMP0,IDWPT0,IDIR0,ISPD0 C C Check height...if missing, then dump the line C IF(IHGT0 .EQ. 32767) GO TO 300 C C Store the data in the arrays and unpack values as necessary C NLVLS=NLVLS+1 HGT(NLVLS)=IHGT0 PRESS(NLVLS)=IPRESS0 DIR(NLVLS)=IDIR0 IF(ISPD0 .EQ. 32767) THEN !missing data flag SPD(NLVLS) = ISPD0 ELSE IF(IWFLAG .EQ. 1) THEN !meters/sec to meters/sec SPD(NLVLS)=ISPD0 ELSE IF(IWFLAG .EQ. 2) THEN !1/10's meters/sec to meter/sec SPD(NLVLS)=FLOAT(ISPD0)/10. ELSE IF(IWFLAG .EQ. 3) THEN !knots to meters/sec SPD(NLVLS)=FLOAT(ISPD0)/1.94 END IF IF(ITEMP0 .EQ. 32767) THEN !Missing data flag TEMP(NLVLS)=ITEMP0 ELSE TEMP(NLVLS)=FLOAT(ITEMP0)/10. !Good data...divide by 10 END IF IF(IDWPT0 .EQ. 32767) THEN !Missing data flag DWPT(NLVLS)=IDWPT0 ELSE DWPT(NLVLS)=FLOAT(IDWPT0)/10. !Good data...divide by 10 END IF C C Check for KC data flags and convert to GEMPAK flags C IF(HGT(NLVLS) .EQ. 32767.) HGT(NLVLS) = -9999. IF(TEMP(NLVLS) .EQ. 32767.) TEMP(NLVLS) = -9999. IF(DWPT(NLVLS) .EQ. 32767.) DWPT(NLVLS) = -9999. IF(SPD(NLVLS) .EQ. 32767. .OR. SPD(NLVLS) .EQ. 0.)SPD(NLVLS)=-9999. IF(DIR(NLVLS) .EQ. 32767. .OR. DIR(NLVLS) .EQ. 0.)DIR(NLVLS)=-9999. C 300 CONTINUE C C Check latitude, longitude, and elevation C IF(SLAT .EQ. 32767.) SLAT = -9999. IF(SLON .EQ. 32767.) SLON = -9999. IF(ELEV .EQ. 32767.) ELEV = -9999. C C*********************************************************************** C Finished reading and checking the KC data...now write it out to the C GEMPAK file. C C Check if stid needs to be shifted left C IF(STID(1:1) .EQ. ' ') THEN STID(1:3) = STID(2:4) !Shift string left-justify, pad blank STID(4:4) = ' ' END IF C C Pack the data into a single array C CALL PACK(PRESS,TEMP,DWPT,DIR,SPD,HGT,SNDATA,NLVLS,NPARM) C C Select the previously added time C CALL SN_STIM(IFLNO,DATTIM,IRET) IF(IRET .NE. 0) THEN CALL ER_WMSG('SN',IRET,DATTIM,IRET) STOP END IF C C Select a station. If IRET = -11, the station header is not in the C file. Add it to the file, then loop back and try again to select C the station. If the station id is either blank or 999, give it a bogus C value. C 305 CALL SN_SSTN(IFLNO,STID,STID,IDUM,RDUM1,RDUM2,RDUM3,IRET) IF(IRET .eq. -11) THEN ISTN = 1 IF(STID(1:3) .EQ. '999' .OR. STID(1:3) .EQ. ' ') THEN NUMSTN=NUMSTN+1 CALL BOGUS(NUMSTN,STID) ENDIF CALL SN_ASTN(IFLNO,ISTN,STID,ID2,SLAT,SLON,ELEV,' ',' ', 1 NADD,IRET) IF(IRET .NE. 0) THEN CALL ER_WMSG('SN',IRET,STID,IERR) STOP END IF GO TO 305 END IF C C Write the data C CALL SN_WDAT(IFLNO,IHHMM,NLVLS,SNDATA,IRET) IF(IRET .NE. 0) THEN CALL ER_WMSG('SN',IRET,FILNAM,IERR) STOP END IF C C*********************************************************************** C Go read the next sounding (if there is another one) -- when all C data is read and pointer is at EOI, branch to EOI processing below. C GO TO 100 C********************************************************************* C C Error and EOI processing takes place here C 320 CONTINUE WRITE(6,340) FNAME 340 FORMAT(' Error Opening Input File: ',A40) STOP C 360 CONTINUE CALL SN_CLOS(IFLNO,IRET) WRITE(6,400) FILNAM 400 FORMAT(' File ',A14, ' created') END SUBROUTINE PACK(P,T,TD,DIR,SPD,HT,SNDATA,NL,NPARMS) REAL P (NL),T (NL),TD (NL),HT (NL),DIR (NL),SPD (NL) !INPUT REAL SNDATA(NPARMS,NL) C C PACK 1-D ARRAYS INTO A SINGLE 2-D ARRAY C DO J = 1,NL SNDATA(1,J) = P(J) SNDATA(2,J) = T(J) SNDATA(3,J) = TD(J) SNDATA(4,J) = DIR(J) SNDATA(5,J) = SPD(J) SNDATA(6,J) = HT(J) ENDDO RETURN END C SUBROUTINE BOGUS(NUMSTN,STID) C C This routine generates bogus 3-letter station id's for stations that do not C have id's. These stations currently use the value "999" or " " C CHARACTER ID(50)*3,STID*4 C DATA ID 1 /'?01','?02','?03','?04','?05','?06','?07','?08','?09','?10', 2 '?11','?12','?13','?14','?15','?16','?17','?18','?19','?20', 3 '?21','?22','?23','?24','?25','?26','?27','?28','?29','?30', 4 '?31','?32','?33','?34','?35','?36','?37','?38','?39','?40', 5 '?41','?42','?43','?44','?45','?46','?47','?48','?49','?50'/ C STID = ID(NUMSTN)//' ' RETURN END