var/convertor/kma_wave2grid/RFTF2M.inc

   1 C***********************************************************************
   2       SUBROUTINE RFTF2M (N,INC,JUMP,LOT, R, WA,IFAC, WSAVE)
   3       DIMENSION       R(*)       ,WSAVE(*)   ,WA(N)    ,IFAC(*)
   4 C
   5       IF (JUMP .GT. INC) THEN
   6           INCN = (LOT*JUMP)/N
   7       ELSE
   8           INCN = INC
   9       ENDIF
  10           IF(MOD(INCN,16) .EQ. 0) INCN = INCN-1
  11           INCN = MAX(INCN,LOT)
  12 C
  13             N4 = (N/4)*4
  14       IF (N4 .GE. 4) THEN
  15             IABASE = 1
  16             IBBASE = 1+INC
  17             ICBASE = 1+INC+INC
  18             IDBASE = 1+INC+INC+INC
  19             JABASE = 1
  20             JBBASE = 1+INCN
  21             JCBASE = 1+INCN+INCN
  22             JDBASE = 1+INCN+INCN+INCN
  23             INQ  = 4*INC
  24             INQN = 4*INCN
  25 *VOPTION NOFVAL
  26         DO 102 K=1,N4,4
  27             IA = IABASE
  28             IB = IBBASE
  29             IC = ICBASE
  30             ID = IDBASE
  31             JA = JABASE
  32             JB = JBBASE
  33             JC = JCBASE
  34             JD = JDBASE
  35 *VOPTION VEC,NOFVAL
  36 *vdir nodep
  37           DO 101 L=1,LOT
  38             WSAVE(JA) = R(IA)
  39             WSAVE(JB) = R(IB)
  40             WSAVE(JC) = R(IC)
  41             WSAVE(JD) = R(ID)
  42             IA = IA+JUMP
  43             IB = IB+JUMP
  44             IC = IC+JUMP
  45             ID = ID+JUMP
  46             JA = JA+1
  47             JB = JB+1
  48             JC = JC+1
  49             JD = JD+1
  50   101     CONTINUE
  51             IABASE = IABASE+INQ
  52             IBBASE = IBBASE+INQ
  53             ICBASE = ICBASE+INQ
  54             IDBASE = IDBASE+INQ
  55             JABASE = JABASE+INQN
  56             JBBASE = JBBASE+INQN
  57             JCBASE = JCBASE+INQN
  58             JDBASE = JDBASE+INQN
  59   102   CONTINUE
  60       ENDIF
  61       IF (N4 .NE. N) THEN
  62             IABASE = 1+N4*INC
  63             JABASE = 1+N4*INCN
  64 *VOPTION NOFVAL
  65         DO 104 K=N4+1,N
  66             IA = IABASE
  67             JA = JABASE
  68 *VOPTION VEC,NOFVAL
  69 *vdir nodep
  70           DO 103 L=1,LOT
  71             WSAVE(JA) = R(IA)
  72             IA = IA+JUMP
  73             JA = JA+1
  74   103     CONTINUE
  75             IABASE = IABASE+INC
  76             JABASE = JABASE+INCN
  77   104   CONTINUE
  78       ENDIF
  79 C
  80         CALL RFTF1M (N,INCN,LOT, WSAVE, WA,IFAC, R)
  81 C
  82           CF = 1.0/FLOAT(N)
  83 C
  84       IF (N4 .GE. 4) THEN
  85             IABASE = 1
  86             IBBASE = 1+INC
  87             ICBASE = 1+INC+INC
  88             IDBASE = 1+INC+INC+INC
  89             JABASE = 1
  90             JBBASE = 1+INCN
  91             JCBASE = 1+INCN+INCN
  92             JDBASE = 1+INCN+INCN+INCN
  93             INQ  = 4*INC
  94             INQN = 4*INCN
  95 *VOPTION NOFVAL
  96 *vdir nodep
  97         DO 112 K=1,N4,4
  98             IA = IABASE
  99             IB = IBBASE
 100             IC = ICBASE
 101             ID = IDBASE
 102             JA = JABASE
 103             JB = JBBASE
 104             JC = JCBASE
 105             JD = JDBASE
 106 *VOPTION VEC,NOFVAL
 107 *vdir nodep
 108           DO 111 L=1,LOT
 109             R(IA) = CF*WSAVE(JA)
 110             R(IB) = CF*WSAVE(JB)
 111             R(IC) = CF*WSAVE(JC)
 112             R(ID) = CF*WSAVE(JD)
 113             IA = IA+JUMP
 114             IB = IB+JUMP
 115             IC = IC+JUMP
 116             ID = ID+JUMP
 117             JA = JA+1
 118             JB = JB+1
 119             JC = JC+1
 120             JD = JD+1
 121   111     CONTINUE
 122             IABASE = IABASE+INQ
 123             IBBASE = IBBASE+INQ
 124             ICBASE = ICBASE+INQ
 125             IDBASE = IDBASE+INQ
 126             JABASE = JABASE+INQN
 127             JBBASE = JBBASE+INQN
 128             JCBASE = JCBASE+INQN
 129             JDBASE = JDBASE+INQN
 130   112   CONTINUE
 131       ENDIF
 132       IF (N4 .NE. N) THEN
 133             IABASE = 1+N4*INC
 134             JABASE = 1+N4*INCN
 135 *VOPTION NOFVAL
 136         DO 114 K=N4+1,N
 137             IA = IABASE
 138             JA = JABASE
 139 *VOPTION VEC,NOFVAL
 140 *vdir nodep
 141           DO 113 L=1,LOT
 142             R(IA) = CF*WSAVE(JA)
 143             IA = IA+JUMP
 144             JA = JA+1
 145   113     CONTINUE
 146             IABASE = IABASE+INC
 147             JABASE = JABASE+INCN
 148   114   CONTINUE
 149       ENDIF
 150       RETURN
 151       END SUBROUTINE RFTF2M
 152