var/convertor/kma_wave2grid/RFTB2M.inc

   1 C***********************************************************************
   2       SUBROUTINE RFTB2M (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 RFTB1M (N,INCN,LOT, WSAVE, WA,IFAC, R)
  81 C
  82         IF (N4 .GE. 4) THEN
  83             IABASE = 1
  84             IBBASE = 1+INC
  85             ICBASE = 1+INC+INC
  86             IDBASE = 1+INC+INC+INC
  87             JABASE = 1
  88             JBBASE = 1+INCN
  89             JCBASE = 1+INCN+INCN
  90             JDBASE = 1+INCN+INCN+INCN
  91             INQ  = 4*INC
  92             INQN = 4*INCN
  93 *VOPTION NOFVAL
  94         DO 112 K=1,N4,4
  95             IA = IABASE
  96             IB = IBBASE
  97             IC = ICBASE
  98             ID = IDBASE
  99             JA = JABASE
 100             JB = JBBASE
 101             JC = JCBASE
 102             JD = JDBASE
 103 *VOPTION VEC,NOFVAL
 104 *vdir nodep
 105           DO 111 L=1,LOT
 106             R(IA) = WSAVE(JA)
 107             R(IB) = WSAVE(JB)
 108             R(IC) = WSAVE(JC)
 109             R(ID) = WSAVE(JD)
 110             IA = IA+JUMP
 111             IB = IB+JUMP
 112             IC = IC+JUMP
 113             ID = ID+JUMP
 114             JA = JA+1
 115             JB = JB+1
 116             JC = JC+1
 117             JD = JD+1
 118   111     CONTINUE
 119             IABASE = IABASE+INQ
 120             IBBASE = IBBASE+INQ
 121             ICBASE = ICBASE+INQ
 122             IDBASE = IDBASE+INQ
 123             JABASE = JABASE+INQN
 124             JBBASE = JBBASE+INQN
 125             JCBASE = JCBASE+INQN
 126             JDBASE = JDBASE+INQN
 127   112   CONTINUE
 128       ENDIF
 129       IF (N4 .NE. N) THEN
 130             IABASE = 1+N4*INC
 131             JABASE = 1+N4*INCN
 132 *VOPTION NOFVAL
 133         DO 114 K=N4+1,N
 134             IA = IABASE
 135             JA = JABASE
 136 *VOPTION VEC,NOFVAL
 137 *vdir nodep
 138           DO 113 L=1,LOT
 139             R(IA) = WSAVE(JA)
 140             IA = IA+JUMP
 141             JA = JA+1
 142   113     CONTINUE
 143             IABASE = IABASE+INC
 144             JABASE = JABASE+INCN
 145   114   CONTINUE
 146       ENDIF
 147       RETURN
 148       END SUBROUTINE RFTB2M
 149