SUBROUTINE PWOTGM(KFILDO,KFILOG,IP16,NDATE, 1 ID,ITAUH,ITAUM,MODNO,NSEQ,ISCALD, 2 NPROJ,ALAT,ALON,ORIENT,XMESHL,XLAT,NX,NY, 3 RECORD,IA,IC,IPACK,ND5,MINPK, 4 IS0,IS1,IS2,IS4,ND7, 5 IPLAIN,PLAIN,NCHAR, 6 XMISSP,XMISSS,LX,IOCTET, 7 NTOTBY,NTOTRC,L3264B,L3264W,IER) C C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INT140 C PRGMMR: GLAHN ORG: W/OST22 DATE: 2000-09-01 C C ABSTRACT: TO PREPARE FOR PACKING, PACK, AND WRITE A GRIDPOINT RECORD C TO A MOS-2000 SEQUENTIAL FILE. CREATED FOR WRITING IN LAMP. C C PROGRAM HISTORY LOG: C 00-09-01 GLAHN C 00-11-01 GLAHN REMOVED INEFFECTIVE TEST ON IER C 00-11-01 GLAHN ADDED TEST FOR ND5 GE NX*NY AT 105 C 00-12-01 GLAHN REMOVED WRITING DIAGNOSTIC TO KFILDO WHEN IP16 = 0 C 01-02-01 GLAHN MODIFIED CALL TO WRITEP C 01-03-01 GLAHN ADDED PLAIN TO CALL; MODIFIED WRITE TO IP16 C 01-07-01 GLAHN ADDED KFILOG MUST BE GT 0 TO WRITE C 02-12-01 RUDACK MODIFIED FORMAT STATEMENTS TO ADHERE TO THE F90 C COMPILER STANDARDS FOUND ON THE IBM SYSTEM C 03-03-01 GLAHN MODIFIED DIAGNOSTICS AT 100 AND 105; C REMOVED ONE CALL TO TIMPR C 03-04-01 CHARBA CREATED A NEW CODE FOR USE IN THE MOS- C 2000 LIBRARY CALLED PWOTGM. PWOTGM IS C A SLIGHTLY MODIFIED VERSION OF PAWOTG, C WHICH IS IN THE LAMP-2000 LIBRARY. C THE MODIFICATION OF PAWOTG CONSISTS OF C SUBSTITUTING XMESHL (MESHLENGTH AT THE C STANDARD LATITUDE) FOR THE "NOMINAL C MESH" (MESH) AND REMOVING THE CALL TO C SUBROUTINE MSHXMS. C 05-03-07 MALONEY ADDED NCEP DOCBLOCK. ADDED CALLS TO W3TAGE. C 12-06-25 ENGLE MODIFIED CALL TO INCLUDE PLAIN. PLAIN C LANGUAGE IS NOW PACKED BY USING IACHAR FUNCTION. C C USAGE: CALLED BY U140 C C DATA SET USE C INPUT FILES: C FORT.KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (INPUT) C C OUTPUT FILES: C FORT.KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT) C FORT.KFILGO - UNIT NUMBER FOR THE GRIDPOINT OUTPUT C SEQUENTIAL FILE. (OUTPUT) C FORT.IP16 - UNIT NUMBER FOR INDICATING WHEN A RECORD IS C WRITTEN TO THE SEQUENTIAL FILE. (OUTPUT) C C VARIABLES C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) C KFILOG = UNIT NUMBER TO WRITE TDLPACK DATA TO. C MUST BE GT 0 OR WRITING WILL NOT BE DONE. C (INPUT) C IP16 = INDICATES WHETHER (>0) OR NOT (=0) C A STATEMENT WILL BE OUTPUT TO IP(16) C WHEN A SEQUENTIAL FILE IS WRITTEN THROUGH C PWOTGM. (INPUT)) C NDATE = DATE OF DATA IN FORM YYYYMMDDHH. (INPUT) C ID(J) = MOS ID OF VARIABLE TO WRITE (J=1,4). (INPUT) C ITAUH = PROJECTION IN HOURS. (INPUT) C ITAUM = PROJECTION IN MINUTES. (INPUT) C MODNO = MODEL NUMBER. (INPUT) C NSEQ = SEQUENCE NUMBER. (INPUT) C ISCALD = DECIMAL SCALE FACTOR. (INPUT) C NPROJ = MAP PROJECTION NUMBER. (INPUT) C ALAT = LATITUDE OF LL CORNER OF GRID IN DEG. (INPUT) C ALON = LONGITUDE OF LL CORNER OF GRID IN DEG. (INPUT) C ORIENT = LONGITUDE OF GRID ORIENTATION IN DEG. (INPUT) C XLAT = LATITUDE AT WHICH XMESHL IS CORRECT IN DEG. C (INPUT) C NX = X EXTENT OF THE GRID. (INPUT) C NY = Y EXTENT OF THE GRID. (INPUT) C RECORD(J) = GRID OF DATA FOR WRITING (J=1,ND5). (INPUT) C IA(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C IC(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C IPACK(J) = SCRATCH ARRAY USED IN PACKING THE DATA C (J=1,ND5). (INTERNAL) C ND5 = DIMENSION OF RECORD( ), IA( ), IC( ), AND C IPACK( ). ND5 MUST BE GE NX*NY. (INPUT) C MINPK = VALUES ARE PACKED IN GROUPS OF MINIMUM SIZE C MINPK. ONLY WHEN THE NUMBER OF BITS TO HANDLE C A GROUP CHANGES WILL A NEW GROUP BE FORMED. C (INPUT) C IS0(L) = HOLDS THE VALUES TO FURNISH FOR GRIB C SECTION 0 (L=1,ND7). (INTERNAL) C IS1(L) = HOLDS THE VALUES TO FURNISH FOR GRIB C SECTION 1 (L=1,ND7). (INTERNAL) C IS2(L) = HOLDS THE VALUES FOR GRIB SECTION 2 (L=1,ND7). C NOT ACTUALLY USED. (INTERNAL) C IS4(L) = HOLDS THE VALUES FOR GRIB SECTION 4. NONE OF C THE VALUES NEED BE FURNISHED BY THE USER. C IS4(2) IS SET TO INDICATE NON-GRIDPOINT DATA, C COMPLEX PACKING, ORIGINAL SCALED VALUES TO BE C PACKED (NOT SECOND ORDER SPATIAL DIFFERENCES), C AND MISSING VALUES OR NOT DEPENDING ON WHETHER C OR NOT XMISS NE OR EQ ZERO, RESPECTIVELY. C (INTERNAL) C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ),AND IS4( ). C (INPUT) C IPLAIN( , ) = NAME OF VARIABLE TO PACK. THIS IS CHARACTER C DATA IN AN INTEGER ARRAY. (INPUT) C PLAIN = THE PLAIN LANGUAGE DESCRIPTION OF THE VARIABLE C IN ID( ). EQUIVALENCED TO IPLAIN( , ) IN C DRU150. (CHARACTER*32) C NCHAR = THE NUMBER OF CHARACTERS OF PLAIN LANGUAGE C IN PLAIN TO PACK WITH THE DATA. (INPUT) C XMISSP = PRIMARY MISSING VALUE INDICATOR. (INPUT) C XMISSS = SECONDARY MISSING VALUE INDICATOR. C (INPUT) C LX = THE NUMBER OF GROUPS (THE NUMBER OF 2ND ORDER C MINIMA). WHILE NEEDED ONLY IN SUBROUTINE PACK, C IT IS OUTPUT IN THE ARGUMENT LIST OF PWOTGM IN C CASE THE USER WANTS TO KNOW IT. (OUTPUT) C IOCTET = THE TOTAL MESSAGE SIZE IN OCTETS. (OUTPUT) C NTOTBY = THE TOTAL NUMBER OF BYTES IN THE FILE. IT IS C UPDATED WHEN THE DATA IN IPACK( ) ARE WRITTEN. C (INPUT-OUTPUT) C NTOTRC = THE TOTAL NUMBER OF RECORDS IN THE FILE. IT IS C UPDATED AS NEEDED. (INPUT-OUTPUT) C L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING C USED (EITHER 32 OR 64). (INPUT) C L3264W = NUMBER OF WORDS IN 64 BITS (EITHER 1 OR 2). C (INPUT) C IER = STATUS RETURN. C 0 = GOOD VALUE. C 51 = ND5 LT NX*NY. C OTHER VALUES COME FROM CALLED SUBROUTINES AND C SHOULD BE TREATED AS FATAL IN CALLING PROGRAM. C (OUTPUT) C XMESHL = MESH LENGTH OF GRID AT STANDARD LATITUDE (XLAT) C IN METERS. (INPUT) C C SUBPROGRAMS CALLED: C UNIQUE - NONE C LIBRARY: C MOSLIB - PACK2D, UNPKBG, WRITEP, DATPRS C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN C OTHER VALUES RETURNED FROM SUBROUTINES. C C REMARKS: NONE C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 (xlf90 compiler) C MACHINE: IBM SP C C$$$ C CHARACTER*32 PLAIN C DIMENSION RECORD(ND5) DIMENSION IA(ND5),IC(ND5),IPACK(ND5) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION IPLAIN(L3264W,4) DIMENSION ID(4) C IER=0 D CALL TIMPR(KFILDO,KFILDO,'START PWOTGM ') D WRITE(KFILDO,100)(ID(J),J=1,4),XMESHL,ALAT,ALON,ORIENT,XLAT,NX,NY D100 FORMAT(/' IN PWOTGM--ID(J),XMESHL,ALAT,ALON,ORIENT,XLAT,NX,NY'/ D 1 ' ',3I11,I6,F12.4,4F15.8,2I8) C IF(KFILOG.LE.0)GO TO 900 C C CHECK SIZE OF ND5 C IF(ND5.LT.NX*NY)THEN NXY=NX*NY WRITE(KFILDO,105)ND5,NXY,ID,KFILOG 105 FORMAT(/' ****ND5 = ',I8,' MUST BE GE NX*NY =',I8, 1 ' IN PWOTGM. DATA ',4I12/ 2 ' NOT PACKED AND WRITTEN TO UNIT NO.',I4, 3 '. RETURN WITH IER = 51 AT 105.') IER=51 GO TO 900 ENDIF C C ZERO ARRAYS DO 110 J=1,ND7 IS0(J)=0 IS1(J)=0 IS2(J)=0 IS4(J)=0 110 CONTINUE C C FILL ID1( ). ID1(1) IS FILLED BY PACK2D. C IS1(2)=1 C IS1(2) = 1 INDICATES NO BIT MAP AND GRIDPOINT DATA. CALL DATPRS(KFILDO,NDATE,IS1(3)) C IS1(3-6) HOLDS DATE--YYYY, MM, DD, HH. IS1(7)=0 C IS1(7) INDICATES 0 MINUTES. IS1(8)=NDATE C IS1(8) IS FULL DATE YYYYMMDDHH. IS1(9)=ID(1) IS1(10)=ID(2) IS1(11)=ID(3) IS1(12)=ID(4) C IS1(9-12) IS THE ID. IS1(13)=ITAUH C IS1(13) IS THE PROJECTION IN HOURS. IS1(14)=ITAUM C IS1(14) IS THE PROJECTION IN MINUTES. IS1(15)=MODNO C IS1(15) IS THE MODEL OR PROCESS NUMBER. IS1(16)= NSEQ C IS1(16) IS THE MODEL SEQUENCE NUMBER. IS1(17)=ISCALD C IS1(17) IS THE DECIMAL SCALE FACTOR. IS1(18)=0 C IS1(18) IS THE BINARY SCALE FACTOR (NOT IMPLEMENTED). IS1(22)=NCHAR C C PUT PLAIN LANGUAGE INTO IS1( ) FOR PACKING. C LOC=1 C LOC = WORD POSITION IN IPLAIN(1,1) TO START UNPACKING. C UNPKBG UPDATES IT. IPOS=1 C IPOS = BIT POSITION IN IPLAIN(1,1) TO START UNPACKING. C UNPKBG UPDATES IT. C CINTEL C C USE IACHAR FUNCTION TO PUT ONE CHARACTER (BYTE) FROM C PLAIN INTO ONE IS1( ) WORD. C DO J=1, NCHAR IS1(J+22)=IACHAR(PLAIN(J:J)) END DO C DO 120 J=1,NCHAR C CALL UNPKBG(KFILDO,IPLAIN(1,1),4*L3264W,LOC,IPOS, C 1 IS1(J+22),8,L3264B,IER,*900) CC NOTE THAT THIS PUTS ONE BYTE PER IS1( ) WORD. C 120 CONTINUE CINTEL C C FILL ID2( ). ID2(1) IS FILLED BY PACK2D. C IS2(2)=NPROJ C IS2(2) IS THE MAP PROJECTION (E.G., 5 = POLAR STEREOGRAPHIC). IS2(3)=NX C IS2(3) IS THE X EXTENT OF THE GRID. IS2(4)=NY C IS2(4) IS THE Y EXTENT OF THE GRID. IS2(5)=NINT(ALAT*10000.) C IS2(5) IS THE LATITUDE*10000 OF THE LL CORNER OF THE GRID. IS2(6)=NINT(ALON*10000.) C IS2(6) IS THE LONGITUDE*10000 OF THE LL CORNER OF THE GRID. IS2(7)=NINT(ORIENT*10000.) C IS2(7) IS THE GRID ORIENTATION*10000. C*********************************************************************** C CALL MSHXMS(KFILDO,MESH,XMESHN,XMESH) C SUBROUTINE MSHXMS COMPUTES XMESH FROM MESH. C IS2(8)=NINT(XMESH*1000000.) C IS2(8)=NINT(XMESHL*1000.) C IS2(8) IS THE MESH LENGTH IN METERS*1000. C*********************************************************************** IS2(9)=NINT(XLAT*10000.) C IS2(9) IS THE LATITUDE*10000 WHERE XMESHL IS CORRECT. C C PACK FROM RECORD( ) TO IPACK( ). C C write(kfildo,*) is2,nd5,nd7 C CALL PACK2D(KFILDO,RECORD,IA,IC,NX,NY,IS0,IS1,IS2,IS4, 1 ND7,XMISSP,XMISSS,IPACK,ND5, 2 MINPK,LX,IOCTET,L3264B,IER) C C write(kfildo,*) is2,nd5,nd7 C IF(IER.NE.0)GO TO 900 C IER NE 0 FROM PACK2D TREATED AS FATAL WITH RETURN TO CALLING C PROGRAM C IF(IP16.NE.0)THEN WRITE(IP16,150)(ID(J),J=1,4),PLAIN,NDATE, 2 NX,NY,XMESHL,ALAT,ALON 150 FORMAT(/' IN PWOTGM WRITING DATA TO UNIT KFILOG',3I10.9,I10.3, 1 3X,A32,' FOR DATE',I12/ 2 77X,'NX,NY,XMESHL,ALAT,ALON =',2I5,F12.4,2F9.4) ENDIF C CALL WRITEP(KFILDO,KFILOG,IPACK,IOCTET*8/L3264B,NTOTBY,NTOTRC, 1 L3264B,IER) C IER NE 0 FROM UNPKBG, PACK2D, OR WRITEP SHOULD BE TREATED AS C FATAL IN CALLING PROGRAM. C 900 IF(IER.NE.0.AND.IER.NE.70.AND.IER.NE.51)THEN C IER = 51 HAS DIAGNOSTIC ABOVE; C IER = 70 HAS DIAGNOSTIC IN WRITEP. C UNPKBG HAS NO DIAGNOSTIC; PACK2D MAY HAVE. WRITE(KFILDO,901)IER 901 FORMAT(/' ****ERROR IN PWOTGM, IER =',I4) ENDIF C D CALL TIMPR(KFILDO,KFILDO,'END PWOTGM ') C RETURN END