SUBROUTINE PREPQ(DRPTPS,DLONS,DLATS,DPRES, * RTYPES,RSPRES,MQDAT,RMAXERR,RBQS,TEMP, * PSG,NLAT,NLON,NSIG,GLATS,GLONS,SIGL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PREPQ PRELIMINARY WORK BEFORE CALC. Q RESIDUALS C PRGMMR: PARRISH ORG: W/NMC22 DATE: 90-10-11 C C ABSTRACT: PRELIMINARY WORK BEFORE CALC. Q RESIDUALS C C PROGRAM HISTORY LOG: C 90-10-11 PARRISH C C INPUT ARGUMENT LIST: C DRPTPS - OBS TYPE IN, OBS ERROR OUT (LN(PS) UNITS) C DLONS,DLATS - OBS LONGITUDES AND LATITUDES (RADIANS IN AND OUT) C DPRES - PRES (MB*10+QM IN, GRID COORDS IN SIGMA OUT) C RTYPES - PREPDA OBSERVATION TYPES C RSPRES - OBSERVATION PRESSURES C MQDAT - NUMBER OF OBSERVATIONS C RMAXERR - MAXIMUM ALLOWED ERROR C TEMP - 6 HR FORECAST TEMPERATURE ARRAY C PSG - MODEL GUESS LOG(PSFC), P IN CB C NLAT - NUMBER OF GAUSSIAN LATS POLE TO POLE C NLON - NUMBER OF LONGITUDES C NSIG - NUMBER OF SIGMA LEVELS C GLATS,GLONS - GRID LATITUDES AND LONGITUDES C SIGL - SIGMA LAYER MIDPOINT VALUES C C OUTPUT ARGUMENT LIST: C RBQS - SATURATION SPECIFIC HUMIDITIES AT OBS. LOCATIONS C AS INDICATED ABOVE C C ATTRIBUTES: C LANGUAGE: CFT77 C MACHINE: CRAY YMP C C$$$ C-------- C C-CRA DIMENSION DRPTPS(MQDAT),DLONS(MQDAT) C-CRA DIMENSION DLATS(MQDAT),DPRES(MQDAT) C-CRA DIMENSION PSG(NLAT+1,NLON+2) C-CRA DIMENSION GLATS(NLAT),GLONS(NLON),SIGL(NSIG) C-CRA DIMENSION RTYPES(MQDAT) C-CRA DIMENSION RSPRES(MQDAT) C-CRA DIMENSION RMAXERR(MQDAT) C-CRA DIMENSION TEMP(NLAT+1,NLON+2,NSIG) C-CRA DIMENSION RBQS(MQDAT) C-CRA DIMENSION QSCAL(NLAT+1,NLON+2,NSIG) C-CRA DIMENSION RBPRES(MQDAT) C-CRA DIMENSION SIGLL(NSIG) C-CRA DIMENSION RLOW(MQDAT),RHGH(MQDAT) C-CRA DIMENSION RBQ(MQDAT) C DIMENSION DRPTPS(_MQDAT_),DLONS(_MQDAT_) DIMENSION DRPTPS(15000),DLONS(15000) C DIMENSION DLATS(_MQDAT_),DPRES(_MQDAT_) DIMENSION DLATS(15000),DPRES(15000) DIMENSION PSG(96+1,192+2) DIMENSION GLATS(96),GLONS(192),SIGL(28) C DIMENSION RTYPES(_MQDAT_) DIMENSION RTYPES(15000) C DIMENSION RSPRES(_MQDAT_) DIMENSION RSPRES(15000) C DIMENSION RMAXERR(_MQDAT_) DIMENSION RMAXERR(15000) DIMENSION TEMP(96+1,192+2,28) C DIMENSION RBQS(_MQDAT_) DIMENSION RBQS(15000) DIMENSION QSCAL(96+1,192+2,28) C DIMENSION RBPRES(_MQDAT_) DIMENSION RBPRES(15000) DIMENSION SIGLL(28) C DIMENSION RLOW(_MQDAT_),RHGH(_MQDAT_) DIMENSION RLOW(15000),RHGH(15000) C DIMENSION RBQ(_MQDAT_) DIMENSION RBQ(15000) C-------- C-------- C-------- LOCAL SPACE C-------- C-------- C-------- GET LOG(SIG) C-------- C-CRA SIGLL=LOG(SIGL) C DIMENSION SIGLL(NSIG) DO ITMP=1,NSIG SIGLL(ITMP)=LOG(SIGL(ITMP)) ENDDO C-------- C-------- CONVERT OBS LATS AND LONS TO GRID COORDINATES C-------- CALL GDCRDP(DLATS,MQDAT,GLATS,NLAT) CALL GDCRDP(DLONS,MQDAT,GLONS,NLON) C-------- C-------- 3. INTERPOLATE SURFACE PRESSURE C-------- C-------- OBTAIN GUESS SURFACE PRESSURE AT OBS LOCATIONS C-------- CALL INTRP2(PSG,RBPRES,DLATS,DLONS,NLAT,NLON,MQDAT) C-------- C-------- CONVERT OBS PRESSURE TO SIGMA, THEN GET GRID COORDINATES C-------- C-CRA RSPRES=10.*EXP(DPRES) C DIMENSION RSPRES(MQDAT) DO ITMP=1,MQDAT RSPRES(ITMP)=10.*EXP(DPRES(ITMP)) ENDDO C-CRA DPRES=DPRES-RBPRES C DIMENSION DLATS(MQDAT),DPRES(MQDAT) DO ITMP=1,MQDAT DPRES(ITMP)=DPRES(ITMP)-RBPRES(ITMP) ENDDO C-------- CALL GDCRDN(DPRES,MQDAT,SIGLL,NSIG) DO 777 L=1,MQDAT IF(NINT(RTYPES(L)) .EQ. 180) DPRES(L)=1.000 IF(NINT(RTYPES(L)) .EQ. 181) DPRES(L)=1.000 IF(NINT(RTYPES(L)) .EQ. 182) DPRES(L)=1.000 IF(NINT(RTYPES(L)) .EQ. 183) DPRES(L)=1.000 IF(NINT(RTYPES(L)) .EQ. 184) DPRES(L)=1.000 IF(NINT(RTYPES(L)) .EQ. 185) DPRES(L)=1.000 777 CONTINUE C-------- C-------- INTERPOLATE GUESS Q TO OBS LOCATIONS AND GET RESIDUAL C-------- (ALSO INTERPOLATE GUESS QSAT TO OBS LOCATIONS) C-------- C C CALCULATE SATURATION SPECIFIC HUMIDITY C C-CRA QSCAL=0. C DIMENSION QSCAL(NLAT+1,NLON+2,NSIG) DO ITMP=1,(NLAT+1)*(NLON+2)*NSIG QSCAL(ITMP,1,1)=0. ENDDO CALL GENQSAT(TEMP,QSCAL,NLAT/2,NLON,NSIG,PSG,SIGL) CALL INTRP3(QSCAL,RBQS,DLATS,DLONS,DPRES, * NLAT,NLON,NSIG,MQDAT) DO 49 I=1,MQDAT C---------- C---------- SCALE ERRORS BY GUESS QSAT (BUT KEEP > .1 G/KG) C---------- RMAXERR(I)=RMAXERR(I)*RBQS(I) DRPTPS(I)=DRPTPS(I)*RBQS(I) RMAXERR(I)=MAX(.0002,RMAXERR(I)) DRPTPS(I)=MAX(.0001,DRPTPS(I)) C-------- C-------- NOW WE ADJUST THE OBSERVATION ERROR TO REFLECT C-------- THE SIZE OF THE RESIDUAL AND IF EXTRAPOLATION OCCURED, THEN C-------- FURTHER ADJUST ERROR ACCORDING TO AMOUNT OF EXTRAPOLATION. C-------- 49 CONTINUE NUMHGH=0 NUMLOW=0 HGH=-1.E9 XLOW=-1.E9 RSIG=NSIG DO 58 I=1,MQDAT RLOW(I)=MIN(DPRES(I)-1.,0.) RHGH(I)=MAX(DPRES(I)-.001-RSIG,0.) RHGH(I)=ABS(RHGH(I)) RLOW(I)=ABS(RLOW(I)) IF(RHGH(I).NE.0.) NUMHGH=NUMHGH+1 IF(RLOW(I).NE.0.) NUMLOW=NUMLOW+1 HGH=MAX(RHGH(I),HGH) XLOW=MAX(RLOW(I),XLOW) 58 CONTINUE WRITE(6,900)MQDAT,NUMHGH,NUMLOW,HGH,XLOW 900 FORMAT(' NUMBER OF QS=',I8,' NUMBER EXTRAPOLATED ABOVE', * ' TOP SIGMA LAYER=',I8,/,' NUMBER EXTRAPOLATED BELOW', * ' BOTTOM SIGMA LAYER=',I8,/,' LARGEST EXTRAPOLATION', * ' ABOVE=',F12.2,/,' LARGEST EXTRAPOLATION BELOW=',F12.2) CDIR$ IVDEP DO 908 I=1,MQDAT DRPTPS(I)=1./(DRPTPS(I) * +1.E6*RHGH(I)+4.*RLOW(I))**2 908 CONTINUE RETURN END