var/convertor/kma_wave2grid/PACK.inc

   1       SUBROUTINE PACK (Z,IDA,STAND,AMP,NGRID)
   2 C
   3       REAL*8    Z(NGRID), DMAX, DMIN
   4 Crizvi      INTEGER*2 IDA(NGRID)
   5       INTEGER IDA(NGRID)
   6
   7       CMAX=32767.0
   8
   9 *    ******* SCALING PART *******
  10
  11 Crizvi      DMAX = -1.0E75
  12 Crizvi      DMIN =  1.0E75
  13       DMAX = -1.0E38
  14       DMIN =  1.0E38
  15       DO 20 I=1,NGRID
  16        DMAX = MAX(DMAX,Z(I))
  17        DMIN = MIN(DMIN,Z(I))
  18    20 CONTINUE
  19       STAND=(DMAX+DMIN)*0.5
  20       AMP  =(DMAX-STAND)/CMAX
  21
  22 *      ***** PACKING PART  *******
  23
  24       IF(AMP.EQ.0.0) THEN
  25         RAMP=1.0
  26       ELSE
  27         RAMP=1.0/AMP
  28       END IF
  29 C
  30       DO 40 I=1,NGRID
  31        WORK=(Z(I)-STAND)*RAMP
  32        IF(WORK.GT.0.0) THEN
  33          IDA(I)=INT(WORK+0.5)
  34        ELSE
  35          IDA(I)=INT(WORK-0.5)
  36        END IF
  37    40 CONTINUE
  38 C
  39       RETURN
  40       END SUBROUTINE PACK
  41
  42 C*********************************************************************
  43       SUBROUTINE CR4I2V(RDATA,BASE,AMP,IDATA,LM)
  44 ************************************************************************
  45 *     ( IN ) RDATA   R*4(LM)     : ŽÀ�””z—ñ
  46 *     ( OUT) BASE    R*4         : Šî�€’l
  47 *     ( OUT) AMP     R*4         : ŒW�”
  48 *     ( OUT) IDATA   I*2(LM)     : �®�””z—ñ
  49 *     ( IN ) LM      I*4         : ƒf�[ƒ^�”
  50 *
  51 ************************************************************************
  52 *
  53 Crizvi      REAL*4    RDATA(LM),RMAX,RMIN,DIST,DBASE,EXPV
  54       REAL    RDATA(LM),RMAX,RMIN,DIST,DBASE,EXPV
  55       INTEGER*4 IDATA(*)
  56 Crizvi      REAL*4    DVAL/32760.E0/
  57       REAL    DVAL/32760.E0/
  58 Crizvi      INTEGER*2 HZERO/0/,HWORK
  59       INTEGER HZERO/0/,HWORK
  60 *
  61 *   GET BASE,AMP
  62 *
  63       RMAX=RDATA(1)
  64       RMIN=RDATA(1)
  65       DO 10 I=2,LM
  66          IF (RDATA(I).GT.RMAX) RMAX=RDATA(I)
  67          IF (RDATA(I).LT.RMIN) RMIN=RDATA(I)
  68    10 CONTINUE
  69       DIST=(RMAX-RMIN)/2
  70       DBASE=(RMIN+RMAX)/2
  71       BASE=DBASE
  72       AMP=DIST/DVAL
  73 *
  74 *    PACK
  75 *
  76       IF (DIST.EQ.0) THEN              ! ALL SAME
  77          DO 20 I=1,LM/2
  78             IDATA(I)=0
  79    20    CONTINUE
  80          IF ((LM/2)*2.NE.LM) THEN                    ! LM ODD
  81 Crizvi            CALL MOVEC(IDATA(LM/2+1),1,HZERO,1,2)
  82          IDATA(LM/2+1) = HZERO * 65536
  83
  84          END IF
  85       ELSE                             ! NORMAL DATA
  86          EXPV=DVAL/DIST
  87 *cdir nodep
  88          DO 30 I=2,LM,2
  89             IWORK=NINT((RDATA(I)-DBASE)*EXPV)        ! EVEN PART
  90             IF (IWORK.GE.0) THEN
  91                IDATA(I/2)=NINT((RDATA(I-1)-DBASE)*EXPV)*65536+IWORK
  92             ELSE
  93                IDATA(I/2)=(NINT((RDATA(I-1)-DBASE)*EXPV)+1)*65536+IWORK
  94             END IF
  95    30    CONTINUE
  96          IF ((LM/2)*2.NE.LM) THEN                    ! LM ODD
  97             HWORK=NINT((RDATA(LM)-DBASE)*EXPV)
  98 Crizvi            CALL MOVEC(IDATA(LM/2+1),1,HWORK,1,2)
  99          IDATA(LM/2+1) = HWORK * 65536
 100          END IF
 101       END IF
 102 *
 103       RETURN
 104       END SUBROUTINE CR4I2V
 105
 106 C*********************************************************************
 107 C   >>>   ƒf�[ƒ^‚ðƒAƒ“ƒpƒbƒN‚·‚é�iƒxƒNƒgƒ‹”Å�j                  <<<
 108 C*********************************************************************
 109       SUBROUTINE CI2R4V(RDATA,BASE,AMP,IDATA,LM)
 110 ************************************************************************
 111 *
 112 *   �”’l—\•ñ‰Û—¬‚QƒoƒCƒg�®�”Œ^ƒf�[ƒ^”z—ñ‚ð‚SƒoƒCƒgŽÀ�”‚É•ÏŠ·‚·‚é�B
 113 *   �i‚r‚R‚W‚O‚OƒxƒNƒgƒ‹�ˆ—�—p�j
 114 *                                      1995.11.06   ’†–ì�®
 115 *    ˆø�”
 116 *     ( OUT) RDATA   R*4(LM)     : ŽÀ�””z—ñ
 117 *     ( IN ) BASE    R*4         : Šî�€’l
 118 *     ( IN ) AMP     R*4         : ŒW�”
 119 *     ( IN ) IDATA   I*2(LM)     : �®�””z—ñ
 120 *     ( IN ) LM      I*4         : ƒf�[ƒ^�”
 121 *
 122 *     •K—v‚ÈƒTƒuƒ‹�[ƒ`ƒ“ –³‚µ
 123 *     ’�ˆÓ�F‚h‚c‚`‚s‚`‚ÍŒê‹«ŠE‚É‚ ‚é‚±‚Æ�B
 124 *
 125 ************************************************************************
 126 *
 127 Crizvi      REAL*4    RDATA(LM)
 128       REAL    RDATA(LM)
 129 cshc-rizvi start
 130 c     INTEGER*4 IDATA(*)
 131       INTEGER*2 IDATA(*)
 132 cshc-rizvi end
 133       INTEGER*2 HWORK
 134 C      INTEGER HWORK
 135 *
 136       DO 10 I=2,LM,2
 137          IWRK=IDATA(I/2)/65536
 138          IRMN=IDATA(I/2)-IWRK*65536
 139          IF (IRMN.EQ.0) THEN                     ! LOWER-HALF=0
 140             RDATA(I-1)=BASE+AMP*IWRK
 141             RDATA(I)  =BASE
 142          ELSE IF (IRMN.GT.0) THEN
 143             RDATA(I-1)=BASE+AMP*IWRK
 144             IF (IRMN.LT.32768) THEN
 145                RDATA(I)=BASE+AMP*IRMN
 146             ELSE
 147                RDATA(I)=BASE+AMP*(IRMN-65536)
 148             END IF
 149          ELSE
 150             RDATA(I-1)=BASE+AMP*(IWRK-1)
 151             IF (IRMN.LT.-32768) THEN
 152                RDATA(I)=BASE+AMP*(IRMN+65536)
 153             ELSE
 154                RDATA(I)=BASE+AMP*IRMN
 155             END IF
 156          END IF
 157    10 CONTINUE
 158       IF ((LM/2)*2.NE.LM) THEN                    ! LM ODD
 159 Crizvi         CALL MOVEC(HWORK,1,IDATA(LM/2+1),1,2)
 160          HWORK=IDATA(LM/2+1)/65536
 161          RDATA(LM)=BASE+AMP*HWORK
 162       END IF
 163 *
 164       RETURN
 165       END SUBROUTINE CI2R4V
 166
 167 C*********************************************************************
 168 C   >>>   ƒf�[ƒ^‚ðƒAƒ“ƒpƒbƒN‚·‚é�iƒxƒNƒgƒ‹”Å�j                  <<<
 169 C*********************************************************************
 170       SUBROUTINE CI2R8V(RDATA,BASE,AMP,IDATA,LM)
 171 ************************************************************************
 172 *
 173 *   �”’l—\•ñ‰Û—¬‚QƒoƒCƒg�®�”Œ^ƒf�[ƒ^”z—ñ‚ð‚WƒoƒCƒgŽÀ�”‚É•ÏŠ·‚·‚é�B
 174 *   �i‚r‚R‚W‚O‚OƒxƒNƒgƒ‹�ˆ—�—p�j
 175 *                                      1995.11.07   ’†–ì�®
 176 *    ˆø�”
 177 *     ( OUT) RDATA   R*8(LM)     : ŽÀ�””z—ñ
 178 *     ( IN ) BASE    R*4         : Šî�€’l
 179 *     ( IN ) AMP     R*4         : ŒW�”
 180 *     ( IN ) IDATA   I*2(LM)     : �®�””z—ñ
 181 *     ( IN ) LM      I*4         : ƒf�[ƒ^�”
 182 *
 183 *     •K—v‚ÈƒTƒuƒ‹�[ƒ`ƒ“ –³‚µ
 184 *     ’�ˆÓ�F‚q‚c‚`‚s‚`‚Í‚QŒê‹«ŠE�A‚h‚c‚`‚s‚`‚ÍŒê‹«ŠE‚É‚ ‚é‚±‚Æ�B
 185 *
 186 ************************************************************************
 187 *
 188       REAL*8    RDATA(LM)
 189       INTEGER*4 IDATA(*)
 190       INTEGER*2 HWORK
 191 c     INTEGER HWORK
 192 *
 193       DO 10 I=2,LM,2
 194          IWRK=IDATA(I/2)/65536
 195          IRMN=IDATA(I/2)-IWRK*65536
 196          IF (IRMN.EQ.0) THEN                     ! LOWER-HALF=0
 197             RDATA(I-1)=BASE+AMP*IWRK
 198             RDATA(I)  =BASE
 199          ELSE IF (IRMN.GT.0) THEN
 200             RDATA(I-1)=BASE+AMP*IWRK
 201             IF (IRMN.LT.32768) THEN
 202                RDATA(I)=BASE+AMP*IRMN
 203             ELSE
 204                RDATA(I)=BASE+AMP*(IRMN-65536)
 205             END IF
 206          ELSE
 207             RDATA(I-1)=BASE+AMP*(IWRK-1)
 208             IF (IRMN.LT.-32768) THEN
 209                RDATA(I)=BASE+AMP*(IRMN+65536)
 210             ELSE
 211                RDATA(I)=BASE+AMP*IRMN
 212             END IF
 213          END IF
 214    10 CONTINUE
 215       IF ((LM/2)*2.NE.LM) THEN                    ! LM ODD
 216 Crizvi         CALL MOVEC(HWORK,1,IDATA(LM/2+1),1,2)
 217          HWORK=IDATA(LM/2+1)/65536
 218          RDATA(LM)=BASE+AMP*HWORK
 219       END IF
 220 *
 221       RETURN
 222       END SUBROUTINE CI2R8V
 223 *
 224 C*********************************************************************
 225       SUBROUTINE MOVERD(DATIN,DATOUT,N)
 226       DIMENSION DATIN(N)
 227       REAL*8    DATOUT(N)
 228 C
 229       DO 100 I=1,N
 230       DATOUT(I)=DATIN(I)
 231   100 CONTINUE
 232 C
 233       RETURN
 234       END SUBROUTINE MOVERD
 235
 236 C*********************************************************************
 237       SUBROUTINE GETTYP(NFL,IOTYP)
 238       CHARACTER*4 GVSD
 239       REWIND NFL
 240 C
 241       READ(NFL,'(2A4)',ERR=10) GVSD, GVSD
 242    10 REWIND NFL
 243       IF( GVSD.EQ.'GVD1' ) THEN
 244         IOTYP=1
 245         RETURN
 246       ENDIF
 247 C
 248       READ(NFL,ERR=20) GVSD
 249    20 REWIND NFL
 250       IF( GVSD.EQ.'GVS1' ) THEN
 251         IOTYP=3
 252         RETURN
 253       ENDIF
 254 C
 255       IOTYP=-1
 256 C
 257       RETURN
 258       END SUBROUTINE GETTYP
 259