0a1
> C-----------------------------------------------------------------------
5c6
< C   PRGMMR: IREDELL          ORG: NP23        DATE: 97-03-05  
---
> C   PRGMMR: IREDELL          ORG: NP23        DATE: 1998-10-22
23c24,26
< C   98-07-03  EBISUZAKI Linux port
---
> C   97-03-18  IREDELL  INCREASED VERBOSITY
> C 1998-09-03  IREDELL  INSTRUMENTED AND MADE PLATFORM-INDEPENDENT
> C 1998-11-17  IREDELL  ADDED SCALING OPTION
139d141
< C   FILENV
141d142
< C   ISTRLEN
145c146
< C   EXIT
---
> C   ERREXIT
171d171
< Cmp      CALL FILENV
173c173,186
<       IARG=1
---
> Cmp
> Cmp   workstation check
> Cmp     Need to go from IARG=2 to IARG=NARG+1....workstation seems to
> Cmp     see the first argument as the name of the executable.  Make sure
> Cmp     the command line starts with copygb.x, not ./copygb.x
> 	CALL GETARG(1,CARG)
>         if (CARG(1:1).EQ.'c' .or. CARG(1:1).EQ.'.') THEN
>         write(6,*) 'increasing NARG by one, and starting at IARG=2'
>         NARG=NARG+1
>         IARG=2
>         else
>         IARG=1
>         endif
> Cmp
176,177c189,190
<         call GETARG(IARG,CARG)
<         LARG=istrlen(CARG)
---
>         CALL GETARG(IARG,CARG)
>         LARG=LEN_TRIM(CARG)
185c198
<           CALL EXIT(1)
---
>           CALL ERREXIT(1)
195c208
<                 LARG=istrlen(CARG)
---
>                 LARG=LEN_TRIM(CARG)
208c221
<                 CALL EXIT(1)
---
>                 CALL ERREXIT(1)
216c229
<                 LARG=istrlen(CARG)
---
>                 LARG=LEN_TRIM(CARG)
226c239
<                 LARG=istrlen(CARG)
---
>                 LARG=LEN_TRIM(CARG)
236c249
<                 LARG=istrlen(CARG)
---
>                 LARG=LEN_TRIM(CARG)
240,243c253
< c             KARG(2:100)=KGDSI(1:99)
<               do ii = 1, 99
<                  KARG(ii+1)=KGDSI(ii)
<               enddo
---
>               KARG(2:100)=KGDSI(1:99)
250,253c260
< c               KGDSI(1:99)=KARG(2:100)
<                 do ii = 1, 99
<                    KGDSI(ii)=KARG(ii+1)
<                 enddo
---
>                 KGDSI(1:99)=KARG(2:100)
259c266
<                 CALL EXIT(1)
---
>                 CALL ERREXIT(1)
262d268
< C	write(6,*) 'LENGDS= ', MI
267c273
<                 CALL EXIT(1)
---
>                 CALL ERREXIT(1)
274c280
<                 LARG=istrlen(CARG)
---
>                 LARG=LEN_TRIM(CARG)
278,281c284
< c             KARG(2:21)=IPOPT
<               do ii = 1, 20
<                  KARG(ii+1)=IPOPT(ii)
<               enddo
---
>               KARG(2:21)=IPOPT
284,287c287
< c             IPOPT=KARG(2:21)
<               do ii = 1, 20
<                   IPOPT(ii)=KARG(ii+1)
<               enddo
---
>               IPOPT=KARG(2:21)
292,293c292,293
<                 call GETARG(IARG,CARG)
<                 LARG=istrlen(CARG)
---
>                 CALL GETARG(IARG,CARG)
>                 LARG=LEN_TRIM(CARG)
302c302
<                 CALL EXIT(1)
---
>                 CALL ERREXIT(1)
309c309
<                 LARG=istrlen(CARG)
---
>                 LARG=LEN_TRIM(CARG)
317c317
<                 CALL EXIT(1)
---
>                 CALL ERREXIT(1)
324c324
<                 LARG=istrlen(CARG)
---
>                 LARG=LEN_TRIM(CARG)
335c335
<                 CALL EXIT(1)
---
>                 CALL ERREXIT(1)
351c351
<                 LARG=istrlen(CARG)
---
>                 LARG=LEN_TRIM(CARG)
367c367
<               CALL EXIT(1)
---
>               CALL ERREXIT(1)
379c379
<         CALL EXIT(NXARG)
---
>         CALL ERREXIT(NXARG)
382c382
<       LCG1=istrlen(CG1)
---
>       LCG1=LEN_TRIM(CG1)
388c388
<         CALL EXIT(8)
---
>         CALL ERREXIT(8)
392c392
<         LCX1=istrlen(CX1)
---
>         LCX1=LEN_TRIM(CX1)
398c398
<           CALL EXIT(8)
---
>           CALL ERREXIT(8)
404c404
<       LCG2=istrlen(CG2)
---
>       LCG2=LEN_TRIM(CG2)
409c409
<           CALL EXIT(1)
---
>           CALL ERREXIT(1)
417c417
<           CALL EXIT(8)
---
>           CALL ERREXIT(8)
437c437
<             CALL EXIT(8)
---
>             CALL ERREXIT(8)
444c444
<               CALL EXIT(8)
---
>               CALL ERREXIT(8)
454,458c454
< 
< Cmp      CALL W3LOG('$S97064.78','COPYGB  ')
< Cmp      CALL W3TAGB('COPYGB  ',0097,0064,0078,'NP23   ')                   
< 
< 
---
>       CALL W3TAGB('COPYGB  ',1998,0295,0047,'NP23   ')
464,467c460
< 
< Cmp        CALL W3LOG('$E')
< Cmp      CALL W3TAGE('COPYGB  ') 
< 
---
>       CALL W3TAGE('COPYGB  ')
541,542c534,535
< C     JB           INTEGER FLAG FOR MAP OPTION
< C     JBK          INTEGER FLAG FOR MAP OPTION
---
> C     JB           INTEGER FLAG FOR MAP OPTIION
> C     JBK          INTEGER FLAG FOR MAP OPTIION
558c551
<       CHARACTER*1 CBUF1(MBUF),CBUFB(MBUF)
---
>       CHARACTER CBUF1(MBUF),CBUFB(MBUF)
566a560
>       IF(LXX.GT.0) CALL INSTRUMENT(5,KALL0,TTOT0,TMIN0,TMAX0)
568,577c562
< c       JPDS=-1
< c       JGDS=-1
< c       KPDSB=0
< c       KGDSB=0
<         do ii = 1, 200
<             JPDS(ii)=-1
<             JGDS(ii)=-1
<             KPDSB(ii)=0
<             KGDSB(ii)=0
<         enddo
---
>         JGDS=-1
578a564,565
>         KPDSB=0
>         KGDSB=0
582,599c569,593
<         IF(IRET.NE.0) THEN
<           CALL ERRMSG('copygb: error retrieving bitmap')
<           CALL EXIT(IRET)
<         ENDIF
<       ENDIF
<       KR1=-1
< c     KPDS1=0
< c     KGDS1=0
<       do ii = 1, 200
<           KPDS1(ii)=0
<           KGDS1(ii)=0
<       enddo
<       CALL GETGBMH(LG1,LX1,KR1,JPDS1,JGDS,
<      &             MBUF,CBUF1,NLEN1,NNUM1,MNUM1,
<      &             K1,M1,KR1,KPDS1,KGDS1,IRET)
<       IF(IRET.NE.0) THEN
<         CALL ERRMSG('copygb: error retrieving requested fields')
<         CALL EXIT(IRET)
---
>         IF(LXX.GT.0) THEN
>           IF(IRET.EQ.99) THEN
>             PRINT *,'copygb map field not found'
>           ELSEIF(IRET.NE.0) THEN
>             PRINT *,'copygb map field retrieval error code ',IRET
>           ENDIF
>         ENDIF
>       ELSE
>         MB=1
>         IRET=0
>       ENDIF
>       IF(IRET.EQ.0) THEN
>         KR1=-1
>         KPDS1=0
>         KGDS1=0
>         CALL GETGBMH(LG1,LX1,KR1,JPDS1,JGDS,
>      &               MBUF,CBUF1,NLEN1,NNUM1,MNUM1,
>      &               K1,M1,KR1,KPDS1,KGDS1,IRET)
>         IF(LXX.GT.0) THEN
>           IF(IRET.EQ.99) THEN
>             PRINT *,'copygb field not found'
>           ELSEIF(IRET.NE.0) THEN
>             PRINT *,'copygb header retrieval error code ',IRET
>           ENDIF
>         ENDIF
607,610c601
< c         KGDSI=KGDS1
<           do ii = 1, 200
<              KGDSI(ii)=KGDS1(ii)
<           enddo
---
>           KGDSI=KGDS1
614,617c605
< c         KGDSI=KGDSB
<           do ii = 1, 200
<              KGDSI(ii)=KGDSB(ii)
<           enddo
---
>           KGDSI=KGDSB
621a610
>         IF(LXX.GT.0) CALL INSTRUMENT(1,KALL1,TTOT1,TMIN1,TMAX1)
624d612
< C	write(6,*) 'calling cpgb1 with KS1= ', KR1-1
632,637c620,621
< c       KPDS1=0
< c       KGDS1=0
<         do ii = 1, 200
<             KPDS1(ii)=0
<             KGDS1(ii)=0
<         enddo
---
>         KPDS1=0
>         KGDS1=0
643c627
<             PRINT *,'copygb GRIB unpacking error code ',IRET
---
>             PRINT *,'copygb header retrieval error code ',IRET
649a634,646
>         CALL INSTRUMENT(1,KALL1,TTOT1,TMIN1,TMAX1)
>         PRINT *,'Instrumentation Report'
>         PRINT '(F10.3," seconds spent searching headers")',TTOT1
>         CALL INSTRUMENT(-2,KALL2,TTOT2,TMIN2,TMAX2)
>         PRINT '(F10.3," seconds spent reading and unpacking")',TTOT2
>         CALL INSTRUMENT(-3,KALL3,TTOT3,TMIN3,TMAX3)
>         PRINT '(F10.3," seconds spent manipulating masks")',TTOT3
>         CALL INSTRUMENT(-4,KALL4,TTOT4,TMIN4,TMAX4)
>         PRINT '(F10.3," seconds spent interpolating or copying")',TTOT4
>         CALL INSTRUMENT(-5,KALL5,TTOT5,TMIN5,TMAX5)
>         PRINT '(F10.3," seconds spent packing and writing")',TTOT5
>         TTOTT=TTOT1+TTOT2+TTOT3+TTOT4+TTOT5
>         PRINT '(F10.3," total seconds spent in copygb")',TTOTT
698,699c695,696
< C     JB           INTEGER FLAG FOR MAP OPTION
< C     JBK          INTEGER FLAG FOR MAP OPTION
---
> C     JB           INTEGER FLAG FOR MAP OPTIION
> C     JBK          INTEGER FLAG FOR MAP OPTIION
730c727
<       CHARACTER*1 CBUF1(MBUF),CBUFB(MBUF)
---
>       CHARACTER CBUF1(MBUF),CBUFB(MBUF)
737c734
<       LOGICAL LR(MF),L1I(MI),LBI(MI)
---
>       LOGICAL*1 LR(MF),L1I(MI),LBI(MI)
742,753c739,741
< c     JGDS=-1
< c     KPDS1=0
< c     KGDS1=0
<       do ii = 1, 200
<          JGDS(ii)=-1
<          KPDS1(ii)=0
<          KGDS1(ii)=0
<       enddo
< Cmp
< C	write(6,*) ' '
< C	write(6,*) 'first getgbm call...KS1= ', ks1
< Cmp
---
>       JGDS=-1
>       KPDS1=0
>       KGDS1=0
765,767d752
< Cmp
< C	write(6,*) 'KPDS1(5),IUV(JUV) ', KPDS1(5),IUV(JUV)
< Cmp
769,772d753
< C	write(6,*) 'in vector part'
< Cmp
< Cmp	look for JPDS that is same as KPDS coming out from
< Cmp	above, but with PDS(5) one greater (v component)
774,781c755,756
< c         JPDS=-1
<           do ii = 1, 200
<               JPDS(ii)=-1
<           enddo
< c         JPDS(1:21)=KPDS1(1:21)
<           do ii = 1, 21
<               JPDS(ii)=KPDS1(ii)
<           enddo
---
>           JPDS=-1
>           JPDS(1:21)=KPDS1(1:21)
783,795c758
< c         JGDS=KGDS1
<           do ii = 1, 200
<               JGDS(ii)=KGDS1(ii)
<           enddo
< C	write(6,*) 'calling 2nd getgbm...looking for following'
< C	write(6,*) 'JPDS(1:12)' ,(JPDS(I),I=1,12)
< 
< Cmp
< 	NLEN1=-1	
< 	NNUM1=-1	
< 	MNUM1=-1	
< 
< Cmp
---
>           JGDS=KGDS1
799,802d761
< 
< C	write(6,*) 'leaving 2nd getgbm...IRET= ', IRET
< C	write(6,*) 'KPDS1(5),JPDS(5)-1 = ', KPDS1(5),JPDS(5)-1
< C
811,812c770,772
< 	ENDIF
<         IF(KRV.EQ.0) THEN
---
>         ELSEIF(IRET.NE.0) THEN
>           PRINT *,'copygb data retrieval error code ',IRET
>         ELSEIF(KRV.EQ.0) THEN
820a781
>         CALL INSTRUMENT(2,KALL2,TTOT2,TMIN2,TMAX2)
835a797
>           CALL INSTRUMENT(3,KALL3,TTOT3,TMIN3,TMAX3)
849a812
>           CALL INSTRUMENT(4,KALL4,TTOT4,TMIN4,TMAX4)
857,860c820
< c       JGDS=-1
<         do ii = 1, 200
<            JGDS(ii)=-1
<         enddo
---
>         JGDS=-1
937a898
>         IF(LXX.GT.0) CALL INSTRUMENT(3,KALL3,TTOT3,TMIN3,TMAX3)
944c905
< 	IF(ISS(1).GT.-100) KPDS1(22)=ISS(1)
---
>         IF(ISS(1).GT.-100) KPDS1(22)=ISS(1)
952,953c913
< Cmp        CALL PUTGB(LG2,MI,KPDS1,KGDSI,L1I,F1I,IRET)
< 	CALL PUTGBN(LG2,MI,KPDS1,KGDSI,IBS,NBIT,L1I,F1I,IRET)
---
>         CALL PUTGBN(LG2,MI,KPDS1,KGDSI,IBS,NBIT,L1I,F1I,IRET)
962,971c922,926
<           IF(IRET.EQ.0) THEN
<             IF(KRV.EQ.0) THEN
<               PRINT *,'       wrote scalar field to record ',NO
<               PRINT *,'       ...KPDS(1:16)=',(KPDS1(I),I=1,16)
<             ELSE
<               PRINT *,'       wrote vector field to records ',NO-1,NO
<               PRINT *,'       ...KPDS(1:16)=',(KPDS1(I),I=1,16)
<               PRINT *,'       ...KPDS(1:16)=',(KPDS1(I),I=1,4),
<      &                KPDS1(5)+1,(KPDS1(I),I=6,16)
<             ENDIF
---
>           IF(IRET.NE.0) THEN
>             PRINT *,'       packing error code ',IRET
>           ELSEIF(KRV.EQ.0) THEN
>             PRINT *,'       wrote scalar field to record ',NO
>             PRINT *,'       ...KPDS(1:16)=',(KPDS1(I),I=1,16)
973c928,931
<             PRINT *,'       GRIB packing error code ',IRET
---
>             PRINT *,'       wrote vector field to records ',NO-1,NO
>             PRINT *,'       ...KPDS(1:16)=',(KPDS1(I),I=1,16)
>             PRINT *,'       ...KPDS(1:16)=',(KPDS1(I),I=1,4),
>      &              KPDS1(5)+1,(KPDS1(I),I=6,16)
974a933
>           CALL INSTRUMENT(5,KALL5,TTOT5,TMIN5,TMAX5)
1001c960
< C     L1           LOGICAL (K1) INPUT BITMAP IF IB1=1
---
> C     L1           LOGICAL*1 (K1) INPUT BITMAP IF IB1=1
1007c966
< C     L2           LOGICAL (K2) OUTPUT BITMAP
---
> C     L2           LOGICAL*1 (K2) OUTPUT BITMAP
1021c980
<       LOGICAL L1(K1),L2(K2)
---
>       LOGICAL*1 L1(K1),L2(K2)
1099c1058
< C     L1           LOGICAL (K1) INPUT BITMAP IF IB1=1
---
> C     L1           LOGICAL*1 (K1) INPUT BITMAP IF IB1=1
1105c1064
< C     L2           LOGICAL (K2) OUTPUT BITMAP
---
> C     L2           LOGICAL*1 (K2) OUTPUT BITMAP
1110,1111c1069,1071
< C   LENGDSF
< C   INTGRIB1
---
> C   IPOLATES
> C   IPOLATEV
> C   IPXWAFS2
1119c1079
<       LOGICAL L1(K1),L2(K2)
---
>       LOGICAL*1 L1(K1),L2(K2)
1122c1082
<       LOGICAL L1F(K1F),L2F(K2F)
---
>       LOGICAL*1 L1F(K1F),L2F(K2F)
1133c1093,1094
<         CALL IPXWAFS(1,K1,K1F,1,KGDS1,F1,KGDS1F,F1F,IRET)
---
>         CALL IPXWAFS2(1,K1,K1F,1,
>      &                KGDS1,IB1,L1,F1,KGDS1F,IB1F,L1F,F1F,IRET)
1135c1096
<           CALL IPOLATES(IP,IPOPT,KGDS1F,KGDS2,K1F,K2,1,IB1,L1F,F1F,
---
>           CALL IPOLATES(IP,IPOPT,KGDS1F,KGDS2,K1F,K2,1,IB1F,L1F,F1F,
1142c1103
<      &                KI,RLAT,RLON,IB2,L2F,F2F,IRET)
---
>      &                KI,RLAT,RLON,IB2F,L2F,F2F,IRET)
1144c1105,1106
<           CALL IPXWAFS(-1,K2,K2F,1,KGDS2,F2,KGDS2F,F2F,IRET)
---
>           CALL IPXWAFS2(-1,K2,K2F,1,
>      &                  KGDS2,IB2,L2,F2,KGDS2F,IB2F,L2F,F2F,IRET)
1149c1111,1112
<         CALL IPXWAFS(1,K1,K1F,1,KGDS1,F1,KGDS1F,F1F,IRET)
---
>         CALL IPXWAFS2(1,K1,K1F,1,
>      &                KGDS1,IB1,L1,F1,KGDS1F,IB1F,L1F,F1F,IRET)
1151,1152c1114,1115
<           CALL IPOLATES(IP,IPOPT,KGDS1F,KGDS2F,K1F,K2F,1,IB1,L1F,F1F,
<      &                  KI,RLAT,RLON,IB2,L2F,F2F,IRET)
---
>           CALL IPOLATES(IP,IPOPT,KGDS1F,KGDS2F,K1F,K2F,1,IB1F,L1F,F1F,
>      &                  KI,RLAT,RLON,IB2F,L2F,F2F,IRET)
1154c1117,1118
<             CALL IPXWAFS(-1,K2,K2F,1,KGDS2,F2,KGDS2F,F2F,IRET)
---
>             CALL IPXWAFS2(-1,K2,K2F,1,
>      &                    KGDS2,IB2,L2,F2,KGDS2F,IB2F,L2F,F2F,IRET)
1169,1170c1133,1136
<         CALL IPXWAFS(1,K1,K1F,1,KGDS1,F1,KGDS1F,F1F,IRET)
<         CALL IPXWAFS(1,K1,K1F,1,KGDS1,G1,KGDS1F,G1F,IRET)
---
>         CALL IPXWAFS2(1,K1,K1F,1,
>      &                KGDS1,IB1,L1,F1,KGDS1F,IB1F,L1F,F1F,IRET)
>         CALL IPXWAFS2(1,K1,K1F,1,
>      &                KGDS1,IB1,L1,G1,KGDS1F,IB1F,L1F,G1F,IRET)
1172c1138,1139
<           CALL IPOLATEV(IP,IPOPT,KGDS1F,KGDS2,K1F,K2,1,IB1,L1F,F1F,G1F,
---
>           CALL IPOLATEV(IP,IPOPT,KGDS1F,KGDS2,K1F,K2,1,
>      &                  IB1F,L1F,F1F,G1F,
1183c1150
<      &                KI,RLAT,RLON,CROT,SROT,IB2,L2F,F2F,G2F,IRET)
---
>      &                KI,RLAT,RLON,CROT,SROT,IB2F,L2F,F2F,G2F,IRET)
1185,1186c1152,1155
<           CALL IPXWAFS(-1,K2,K2F,1,KGDS2,F2,KGDS2F,F2F,IRET)
<           CALL IPXWAFS(-1,K2,K2F,1,KGDS2,G2,KGDS2F,G2F,IRET)
---
>           CALL IPXWAFS2(-1,K2,K2F,1,
>      &                  KGDS2,IB2,L2,F2,KGDS2F,IB2F,L2F,F2F,IRET)
>           CALL IPXWAFS2(-1,K2,K2F,1,
>      &                  KGDS2,IB2,L2,G2,KGDS2F,IB2F,L2F,G2F,IRET)
1191,1192c1160,1163
<         CALL IPXWAFS(1,K1,K1F,1,KGDS1,F1,KGDS1F,F1F,IRET)
<         CALL IPXWAFS(1,K1,K1F,1,KGDS1,G1,KGDS1F,G1F,IRET)
---
>         CALL IPXWAFS2(1,K1,K1F,1,
>      &                KGDS1,IB1,L1,F1,KGDS1F,IB1F,L1F,F1F,IRET)
>         CALL IPXWAFS2(1,K1,K1F,1,
>      &                KGDS1,IB1,L1,G1,KGDS1F,IB1F,L1F,G1F,IRET)
1194,1195c1165,1167
<          CALL IPOLATEV(IP,IPOPT,KGDS1F,KGDS2F,K1F,K2F,1,IB1,L1F,F1F,G1F,
<      &                  KI,RLAT,RLON,CROT,SROT,IB2,L2F,F2F,G2F,IRET)
---
>           CALL IPOLATEV(IP,IPOPT,KGDS1F,KGDS2F,K1F,K2F,1,
>      &                  IB1F,L1F,F1F,G1F,
>      &                  KI,RLAT,RLON,CROT,SROT,IB2F,L2F,F2F,G2F,IRET)
1197,1198c1169,1172
<             CALL IPXWAFS(-1,K2,K2F,1,KGDS2,F2,KGDS2F,F2F,IRET)
<             CALL IPXWAFS(-1,K2,K2F,1,KGDS2,G2,KGDS2F,G2F,IRET)
---
>             CALL IPXWAFS2(-1,K2,K2F,1,
>      &                    KGDS2,IB2,L2,F2,KGDS2F,IB2F,L2F,F2F,IRET)
>             CALL IPXWAFS2(-1,K2,K2F,1,
>      &                    KGDS2,IB2,L2,G2,KGDS2F,IB2F,L2F,G2F,IRET)
1238,1241c1212
< c       KGDSF=KGDS
<         do ii = 1, 200
<             KGDSF(ii)=KGDS(ii)
<         enddo
---
>         KGDSF=KGDS
1244,1247c1215
< c       KGDSF=KGDS
<         do ii = 1, 200
<             KGDSF(ii)=KGDS(ii)
<         enddo
---
>         KGDSF=KGDS
1257,1260c1225
< c       KGDSF=KGDS
<         do ii = 1, 200
<             KGDSF(ii)=KGDS(ii)
<         enddo
---
>         KGDSF=KGDS
1265,1275d1229
< 
< 	INTEGER FUNCTION ISTRLEN(C)
< 	CHARACTER*(*) C
< 	L = LEN(C)
< 	DO ISTRLEN = L, 1, -1
< 	   IF (C(ISTRLEN:ISTRLEN).NE.' ') RETURN
< 	ENDDO
< 	ISTRLEN = 0
< 	RETURN
< 	END
< 
1433c1387
<       LOGICAL LB(KF)
---
>       LOGICAL*1 LB(KF)
1485a1440
> C	write(6,*) 'calling w3fi72'
1493d1447
<