SUBROUTINE PACK (Z,IDA,STAND,AMP,NGRID) C REAL*8 Z(NGRID), DMAX, DMIN Crizvi INTEGER*2 IDA(NGRID) INTEGER IDA(NGRID) CMAX=32767.0 * ******* SCALING PART ******* Crizvi DMAX = -1.0E75 Crizvi DMIN = 1.0E75 DMAX = -1.0E38 DMIN = 1.0E38 DO 20 I=1,NGRID DMAX = MAX(DMAX,Z(I)) DMIN = MIN(DMIN,Z(I)) 20 CONTINUE STAND=(DMAX+DMIN)*0.5 AMP =(DMAX-STAND)/CMAX * ***** PACKING PART ******* IF(AMP.EQ.0.0) THEN RAMP=1.0 ELSE RAMP=1.0/AMP END IF C DO 40 I=1,NGRID WORK=(Z(I)-STAND)*RAMP IF(WORK.GT.0.0) THEN IDA(I)=INT(WORK+0.5) ELSE IDA(I)=INT(WORK-0.5) END IF 40 CONTINUE C RETURN END SUBROUTINE PACK C********************************************************************* SUBROUTINE CR4I2V(RDATA,BASE,AMP,IDATA,LM) ************************************************************************ * ( IN ) RDATA R*4(LM) : 実数配列 * ( OUT) BASE R*4 : 基準値 * ( OUT) AMP R*4 : 係数 * ( OUT) IDATA I*2(LM) : 整数配列 * ( IN ) LM I*4 : データ数 * ************************************************************************ * Crizvi REAL*4 RDATA(LM),RMAX,RMIN,DIST,DBASE,EXPV REAL RDATA(LM),RMAX,RMIN,DIST,DBASE,EXPV INTEGER*4 IDATA(*) Crizvi REAL*4 DVAL/32760.E0/ REAL DVAL/32760.E0/ Crizvi INTEGER*2 HZERO/0/,HWORK INTEGER HZERO/0/,HWORK * * GET BASE,AMP * RMAX=RDATA(1) RMIN=RDATA(1) DO 10 I=2,LM IF (RDATA(I).GT.RMAX) RMAX=RDATA(I) IF (RDATA(I).LT.RMIN) RMIN=RDATA(I) 10 CONTINUE DIST=(RMAX-RMIN)/2 DBASE=(RMIN+RMAX)/2 BASE=DBASE AMP=DIST/DVAL * * PACK * IF (DIST.EQ.0) THEN ! ALL SAME DO 20 I=1,LM/2 IDATA(I)=0 20 CONTINUE IF ((LM/2)*2.NE.LM) THEN ! LM ODD Crizvi CALL MOVEC(IDATA(LM/2+1),1,HZERO,1,2) IDATA(LM/2+1) = HZERO * 65536 END IF ELSE ! NORMAL DATA EXPV=DVAL/DIST *cdir nodep DO 30 I=2,LM,2 IWORK=NINT((RDATA(I)-DBASE)*EXPV) ! EVEN PART IF (IWORK.GE.0) THEN IDATA(I/2)=NINT((RDATA(I-1)-DBASE)*EXPV)*65536+IWORK ELSE IDATA(I/2)=(NINT((RDATA(I-1)-DBASE)*EXPV)+1)*65536+IWORK END IF 30 CONTINUE IF ((LM/2)*2.NE.LM) THEN ! LM ODD HWORK=NINT((RDATA(LM)-DBASE)*EXPV) Crizvi CALL MOVEC(IDATA(LM/2+1),1,HWORK,1,2) IDATA(LM/2+1) = HWORK * 65536 END IF END IF * RETURN END SUBROUTINE CR4I2V C********************************************************************* C >>> データをアンパックする（ベクトル版） <<< C********************************************************************* SUBROUTINE CI2R4V(RDATA,BASE,AMP,IDATA,LM) ************************************************************************ * * 数値予報課流２バイト整数型データ配列を４バイト実数に変換する。 * （Ｓ３８００ベクトル処理用） * 1995.11.06 中野尚 * 引数 * ( OUT) RDATA R*4(LM) : 実数配列 * ( IN ) BASE R*4 : 基準値 * ( IN ) AMP R*4 : 係数 * ( IN ) IDATA I*2(LM) : 整数配列 * ( IN ) LM I*4 : データ数 * * 必要なサブルーチン 無し * 注意：ＩＤＡＴＡは語境界にあること。 * ************************************************************************ * Crizvi REAL*4 RDATA(LM) REAL RDATA(LM) cshc-rizvi start INTEGER*4 IDATA(*) c INTEGER*2 IDATA(*) cshc-rizvi end INTEGER*2 HWORK C INTEGER HWORK * DO 10 I=2,LM,2 IWRK=IDATA(I/2)/65536 IRMN=IDATA(I/2)-IWRK*65536 IF (IRMN.EQ.0) THEN ! LOWER-HALF=0 RDATA(I-1)=BASE+AMP*IWRK RDATA(I) =BASE ELSE IF (IRMN.GT.0) THEN RDATA(I-1)=BASE+AMP*IWRK IF (IRMN.LT.32768) THEN RDATA(I)=BASE+AMP*IRMN ELSE RDATA(I)=BASE+AMP*(IRMN-65536) END IF ELSE RDATA(I-1)=BASE+AMP*(IWRK-1) IF (IRMN.LT.-32768) THEN RDATA(I)=BASE+AMP*(IRMN+65536) ELSE RDATA(I)=BASE+AMP*IRMN END IF END IF 10 CONTINUE IF ((LM/2)*2.NE.LM) THEN ! LM ODD Crizvi CALL MOVEC(HWORK,1,IDATA(LM/2+1),1,2) HWORK=IDATA(LM/2+1)/65536 RDATA(LM)=BASE+AMP*HWORK END IF * RETURN END SUBROUTINE CI2R4V C********************************************************************* C >>> データをアンパックする（ベクトル版） <<< C********************************************************************* SUBROUTINE CI2R8V(RDATA,BASE,AMP,IDATA,LM) ************************************************************************ * * 数値予報課流２バイト整数型データ配列を８バイト実数に変換する。 * （Ｓ３８００ベクトル処理用） * 1995.11.07 中野尚 * 引数 * ( OUT) RDATA R*8(LM) : 実数配列 * ( IN ) BASE R*4 : 基準値 * ( IN ) AMP R*4 : 係数 * ( IN ) IDATA I*2(LM) : 整数配列 * ( IN ) LM I*4 : データ数 * * 必要なサブルーチン 無し * 注意：ＲＤＡＴＡは２語境界、ＩＤＡＴＡは語境界にあること。 * ************************************************************************ * REAL*8 RDATA(LM) INTEGER*4 IDATA(*) INTEGER*2 HWORK c INTEGER HWORK * DO 10 I=2,LM,2 IWRK=IDATA(I/2)/65536 IRMN=IDATA(I/2)-IWRK*65536 IF (IRMN.EQ.0) THEN ! LOWER-HALF=0 RDATA(I-1)=BASE+AMP*IWRK RDATA(I) =BASE ELSE IF (IRMN.GT.0) THEN RDATA(I-1)=BASE+AMP*IWRK IF (IRMN.LT.32768) THEN RDATA(I)=BASE+AMP*IRMN ELSE RDATA(I)=BASE+AMP*(IRMN-65536) END IF ELSE RDATA(I-1)=BASE+AMP*(IWRK-1) IF (IRMN.LT.-32768) THEN RDATA(I)=BASE+AMP*(IRMN+65536) ELSE RDATA(I)=BASE+AMP*IRMN END IF END IF 10 CONTINUE IF ((LM/2)*2.NE.LM) THEN ! LM ODD Crizvi CALL MOVEC(HWORK,1,IDATA(LM/2+1),1,2) HWORK=IDATA(LM/2+1)/65536 RDATA(LM)=BASE+AMP*HWORK END IF * RETURN END SUBROUTINE CI2R8V * C********************************************************************* SUBROUTINE MOVERD(DATIN,DATOUT,N) DIMENSION DATIN(N) REAL*8 DATOUT(N) C DO 100 I=1,N DATOUT(I)=DATIN(I) 100 CONTINUE C RETURN END SUBROUTINE MOVERD C********************************************************************* SUBROUTINE GETTYP(NFL,IOTYP) CHARACTER*4 GVSD REWIND NFL C READ(NFL,'(2A4)',ERR=10) GVSD, GVSD 10 REWIND NFL IF( GVSD.EQ.'GVD1' ) THEN IOTYP=1 RETURN ENDIF C READ(NFL,ERR=20) GVSD 20 REWIND NFL IF( GVSD.EQ.'GVS1' ) THEN IOTYP=3 RETURN ENDIF C IOTYP=-1 C RETURN END SUBROUTINE GETTYP