CR8I2V.inc
References to this file elsewhere.
1 SUBROUTINE CR8I2V(RDATA,BASE,AMP,IDATA,LM)
2 ************************************************************************
3 * ( IN ) RDATA R*8(LM) : 実数配列
4 * ( OUT) BASE R*4 : 基準値
5 * ( OUT) AMP R*4 : 係数
6 * ( OUT) IDATA I*2(LM) : 整数配列
7 * ( IN ) LM I*4 : データ数
8 *
9 *
10 ************************************************************************
11 *
12 REAL*8 RDATA(LM),RMAX,RMIN,DIST,DBASE,EXPV
13 INTEGER*4 IDATA(*) !shc-rizvi
14 c INTEGER*2 IDATA(*) !shc-rizvi
15 REAL*8 DVAL/32760.D0/
16 INTEGER*2 HZERO/0/,HWORK
17 *
18 * GET BASE,AMP
19 *
20 RMAX=RDATA(1)
21 RMIN=RDATA(1)
22 DO I=2,LM
23 IF (RDATA(I).GT.RMAX) RMAX=RDATA(I)
24 IF (RDATA(I).LT.RMIN) RMIN=RDATA(I)
25 END DO
26 DIST=(RMAX-RMIN)/2
27 DBASE=(RMIN+RMAX)/2
28 BASE=DBASE
29 AMP=DIST/DVAL
30 *
31 * PACK
32 *
33 IF (DIST.EQ.0) THEN
34 DO 20 I=1,LM/2
35 IDATA(I)=0
36 20 CONTINUE
37 IF ((LM/2)*2.NE.LM) THEN ! LM ODD
38 Crizvi CALL MOVEC(IDATA(LM/2+1),1,HZERO,1,2)
39 IDATA(LM/2+1) = HZERO * 65536
40 END IF
41 ELSE ! NORMAL DATA
42 EXPV=DVAL/DIST
43 *cdir nodep
44 DO 30 I=2,LM,2
45 IWORK=NINT((RDATA(I)-DBASE)*EXPV) ! EVEN PART
46 IF (IWORK.GE.0) THEN
47 IDATA(I/2)=NINT((RDATA(I-1)-DBASE)*EXPV)*65536+IWORK
48 ELSE
49 IDATA(I/2)=(NINT((RDATA(I-1)-DBASE)*EXPV)+1)*65536+IWORK
50 END IF
51 30 CONTINUE
52 IF ((LM/2)*2.NE.LM) THEN ! LM ODD
53 HWORK=NINT((RDATA(LM)-DBASE)*EXPV)
54 Crizvi CALL MOVEC(IDATA(LM/2+1),1,HWORK,1,2)
55 IDATA(LM/2+1) = HWORK * 65536
56 END IF
57 END IF
58 *
59 RETURN
60 END SUBROUTINE CR8I2V