SUBROUTINE TILE_OUT (MAXTIL,JMAXOT,IS1,JS1,IFIRST,SCAL, & KPDSIN,KGDSOUT,IOUTUN,DOTILE,RLAT,RLON,TYPE4,MDLID, & NOUT,LOUT,FOUT,DATSET,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TILE_OUT C PRGMMR: BALDWIN ORG: NP22 DATE: 98-08-11 C C ABSTRACT: TILE_OUT PACKS UP A FIELD INTO GRIB AND WRITES IT OUT C IN SUBSET OR 'TILED' FORM. C C PROGRAM HISTORY LOG: C 99-03-25 BALDWIN ORIGINATOR C C USAGE: CALL TILE_OUT (MAXTIL,JMAXOT,IS1,JS1,IFIRST,SCAL, C & KPDSIN,KGDSOUT,IOUTUN,DOTILE,RLAT,RLON,TYPE4,MDLID, C & NOUT,LOUT,FOUT,DATSET,IRET) C C INPUT: C MAXTIL INTEGER - MAX NUMBER OF TILES C JMAXOT INTEGER - DIMENSION OF FOUT,LOUT C IS1 INTEGER - NUMBER OF TILES IN X DIR C JS1 INTEGER - NUMBER OF TILES IN Y DIR C IFIRST LOGICAL - FIRST TIME FOR THIS GRID? C SCAL REAL - BINARY SCALE FACTOR C KPDSIN(25) INTEGER - KPDS FOR INPUT C KGDSOUT(22) INTEGER - KGDS FOR OUTPUT GRID C IOUTUN(MAXTIL) INTEGER - UNIT TO WRITE OUTPUT TO C DOTILE(MAXTIL) LOGICAL - .F. IF ALL TILE POINTS MISSING C RLAT(JMAXOT) REAL - LATITUDE OF OUTPUT GRID POINTS C RLON(JMAXOT) REAL - LONGITUDE OF OUTPUT GRID POINTS C TYPE4 CHAR*4 - TYPE OF WMO HEADER INFO TO ADD C MDLID INTEGER - MODEL ID NUMBER PDS OCTET 6 C NOUT INTEGER - NUMBER OF POINTS IN OUTPUT GRID C LOUT(JMAXOT) LOGICAL - BITMAP CORRESPONDING TO FOUT C FOUT(JMAXOT) REAL - FIELD TO OUTPUT C DATSET CHAR*16 - OUTPUT FILE NAME PREFIX C C OUTPUT: C IRET INTEGER - RETURN CODE C C RETURN CODES: C IRET = 0 - NORMAL EXIT C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE : CRAY J-916 C C PARAMETER (LUNKWB=41,LUNTIM=42,LUNPRM=43,LUNGRD=44,LUNLVL=45) PARAMETER(KGRID1=255,IOUT=100,JOUT=IOUT*IOUT) INTEGER KPDSIN(25),KPDSOUT(25),KGDSOUT(22),KGDSTILE(22) c INTEGER KPDSIN(200),KPDSOUT(200),KGDSOUT(200),KGDSTILE(200) INTEGER IOUTUN(MAXTIL),IDUM(MAXTIL) LOGICAL*1 LOUT(JMAXOT),LTIL(JOUT,MAXTIL),DOTILE(MAXTIL) LOGICAL*1 TOUT(JOUT),IFIRST REAL FOUT(JMAXOT) REAL FTIL(JOUT,MAXTIL),FONE(JOUT) REAL RLAT(JMAXOT),RLON(JMAXOT) CHARACTER TYPE4*4,TYPE1*1 CHARACTER GRIB(200+17*JOUT/8),GRIBWMO(210+17*JOUT/8) CHARACTER FNAME*104,DATSET*16,FILE2*16 CHARACTER FSTHR*16,RESTHR*4,ENVAR*40 C IRET=0 C C HOW BIG ARE THE TILES? C IMF=KGDSOUT(2) JMF=KGDSOUT(3) IINC=IMF/IS1 + 1 JINC=JMF/JS1 + 1 IF (MOD(IMF,IS1).EQ.0) IINC=IINC-1 IF (MOD(JMF,JS1).EQ.0) JINC=JINC-1 NUMTIL=IS1*JS1 C C COMPUTE TILES C IDUM=0 DO KFINE=1,NOUT C C IFINE,JFINE ARE I,J ON OUTPUT GRID C JFINE=(KFINE-1)/IMF + 1 IFINE=MOD(KFINE,IMF) IF (IFINE.EQ.0) IFINE=IMF C C ITILE,JTILE ARE I,J ON TILE GRID, K1 IS THE INDEX ON THE TILE C NTILE IS THE INDEX OF THE TILE ITSELF C ITILE=MOD(IFINE,IINC) JTILE=MOD(JFINE,JINC) IF (ITILE.EQ.0) ITILE=IINC IF (JTILE.EQ.0) JTILE=JINC INUMT=(IFINE-1)/IINC + 1 JNUMT=(JFINE-1)/JINC + 1 IMAXT=IMF-(IS1-1)*IINC IF (INUMT.LT.IS1) THEN K1=(JTILE-1)*IINC+ITILE ELSE K1=(JTILE-1)*IMAXT+ITILE ENDIF NTILE=(JNUMT-1)*IS1 + INUMT LTIL(K1,NTILE)=LOUT(KFINE) FTIL(K1,NTILE)=FOUT(KFINE) IF (LTIL(K1,NTILE)) IDUM(NTILE)=IDUM(NTILE)+1 ENDDO C C OPEN TILE FILES C IF (IFIRST) THEN IFIRST=.FALSE. IOUT1=60 C C GET FULL PATH FOR OUTPUT FILE FROM ENVIRONMENT VARIABLE C COMSP WHICH IS SET IN THE SCRIPT RUNNING THE MODEL. C RESTHR GETS APPENDED TO THE NAME C FSTHR IS THE FORECAST HOUR C ENVAR = ' ' RESTHR = ' ' FSTHR = ' ' CALL get_environment_variable('COMSP',ENVAR) CALL get_environment_variable('tmmark',RESTHR) CALL get_environment_variable('fhr',FSTHR) KENV = INDEX(ENVAR,' ') -1 IF (KENV.LE.0) KENV = LEN(ENVAR) KTHR = INDEX(RESTHR,' ') -1 IF (KTHR.LE.0) KTHR = LEN(RESTHR) KFHR = INDEX(FSTHR,' ') -1 IF (KFHR.LE.0) KFHR = LEN(FSTHR) KDAT = INDEX(DATSET,' ') -1 IF (KDAT.LE.0) KDAT = LEN(DATSET) DO NTILE=1,NUMTIL INUMT=MOD(NTILE,IS1) IF (INUMT.EQ.0) INUMT=IS1 JNUMT=(NTILE-1)/IS1 + 1 ISTART=(INUMT-1)*IINC+1 IEND=INUMT*IINC IF (IEND.GT.IMF) IEND=IMF JSTART=(JNUMT-1)*JINC+1 JEND=JNUMT*JINC IF (JEND.GT.JMF) JEND=JMF INUM=IEND-ISTART+1 JNUM=JEND-JSTART+1 KO=INUM*JNUM C C CHECK IF WE NEED TO DO A TILE (IS TILE WITHIN DOMAIN?) C IF (IDUM(NTILE).EQ.0) THEN DOTILE(NTILE)=.FALSE. IOUTUN(NTILE)=0 ELSE IOUT1=IOUT1+1 DOTILE(NTILE)=.TRUE. IOUTUN(NTILE)=IOUT1 WRITE(FILE2,3300) NTILE 3300 FORMAT('.',I2.2) C C CONSTRUCT FULL PATH-FILENAME FOR OUTPUT FILE IF (ENVAR(1:4).EQ.' ') THEN IF (RESTHR(1:4).EQ.' ') THEN FNAME = DATSET(1:KDAT) // FSTHR(1:KFHR) // FILE2 ELSE FNAME = DATSET(1:KDAT) // FSTHR(1:KFHR) // '.' // RESTHR & // FILE2 ENDIF ELSE IF (RESTHR(1:4).EQ.' ') THEN FNAME = ENVAR(1:KENV) // DATSET(1:KDAT) // FSTHR(1:KFHR) & // FILE2 ELSE FNAME = ENVAR(1:KENV) // DATSET(1:KDAT) // FSTHR(1:KFHR) & //'.'// RESTHR // FILE2 ENDIF ENDIF CALL BAOPENW(IOUT1,FNAME,IER) ENDIF ENDDO ENDIF C C PACK UP AND WRITE OUT TILES C DO NTILE=1,NUMTIL IF (DOTILE(NTILE)) THEN INUMT=MOD(NTILE,IS1) IF (INUMT.EQ.0) INUMT=IS1 JNUMT=(NTILE-1)/IS1 + 1 ISTART=(INUMT-1)*IINC+1 IEND=INUMT*IINC IF (IEND.GT.IMF) IEND=IMF JSTART=(JNUMT-1)*JINC+1 JEND=JNUMT*JINC IF (JEND.GT.JMF) JEND=JMF IOUT2=IOUTUN(NTILE) KST=(JSTART-1)*IMF + ISTART KEND=(JEND-1)*IMF+IEND INUM=IEND-ISTART+1 JNUM=JEND-JSTART+1 KO=INUM*JNUM C C FIGURE OUT NUMBER OF BITS TO USE TO PACK FTIL C FMAX=-1.E33 FMIN=1.E33 DO K1=1,KO IF(LTIL(K1,NTILE))FMAX=AMAX1(FTIL(K1,NTILE),FMAX) IF(LTIL(K1,NTILE))FMIN=AMIN1(FTIL(K1,NTILE),FMIN) TOUT(K1)=LTIL(K1,NTILE) FONE(K1)=FTIL(K1,NTILE) ENDDO CALL FNDBIT ( FMIN, FMAX, SCAL, NBITSOUT, & ISCALO, RMN, IRET5) IBOUT1=0 IF (IDUM(NTILE).LT.KO) IBOUT1=1 C C SET UP TILE KGDS AND KPDS C KPDSOUT=KPDSIN KPDSOUT(22)=ISCALO KPDSOUT(2)=MDLID KGRIDT=KGRID1 ! could add logic for PR grid #237 KPDSOUT(3)=KGRIDT KPDSOUT(4)=128+64*IBOUT1 KGDSTILE=KGDSOUT KGDSTILE(2)= INUM KGDSTILE(3)= JNUM KGDSTILE(4)=NINT(RLAT(KST)*1000.) KGDSTILE(5)=NINT((RLON(KST)-360.0)*1000.) CMEB FOR SOME REASON GEMPAK DOESNT LIKE EAST LON? IF (KGDSTILE(1).EQ.0.OR.KGDSTILE(1).EQ.1) THEN KGDSTILE(7)=NINT(RLAT(KEND)*1000.) KGDSTILE(8)=NINT((RLON(KEND)-360.0)*1000.) C KGDSTILE(8)=NINT(RLON(KEND)*1000.) ENDIF C C PACK AND WRITE C IF (IRET5.NE.0) THEN IRET=IRET5 RETURN ELSE CALL PUT_GB(kgrid1,KO,NBITSOUT,KPDSOUT,KGDSTILE, & TOUT,FONE,LGRIB,GRIB,IRET6) IF (IRET6.NE.0) THEN IRET=IRET6 RETURN ELSE LUGBOUT=IOUTUN(NTILE) NUMT=INDEX(TYPE4,' ')-1 IF (NUMT.LT.0) NUMT=LEN(TYPE4) DO II=1,NUMT TYPE1=TYPE4(II:II) IF (TYPE1.NE.'X') THEN CALL ADD_WMO ( GRIB, TYPE1, & LUNKWB, LUNTIM, LUNPRM, LUNGRD, LUNLVL, & GRIBWMO, LGRIB1, IRET7) IF (IRET7.EQ.0) THEN CALL WRYTE(LUGBOUT,LGRIB1,GRIBWMO) ENDIF ELSE CALL WRYTE(LUGBOUT,LGRIB,GRIB) ENDIF ENDDO ENDIF ENDIF C END OF DOTILE IF TEST ENDIF C END OF LOOP OVER NUMBER OF TILES ENDDO RETURN END