var/convertor/kma_wave2grid/LGNUV.inc

   1       SUBROUTINE LGNUV
   2      I(MEND1,NEND1,JEND1,MNWAV,IMAX,JMAX,JMAXHF,KMAX,PNM,DPNM,
   3      I QPSIX,QCHIX,
   4      O GUX  ,GVX   ,
   5      W GWRK)
   6 C
   7
   8       DIMENSION Q(KMAX,5,MNWAV)
   9       DIMENSION QR(KMAX,5,MNWAV)
  10       DIMENSION QPSIX(2,KMAX,MNWAV) ,QCHIX(2,KMAX,MNWAV)
  11       DIMENSION DPNM(MNWAV,JMAXHF)  ,PNM (MNWAV,JMAXHF)
  12
  13
  14       DIMENSION GU(KMAX,4,MEND1,2)
  15       DIMENSION GUX (IMAX,JMAX,KMAX),GVX (IMAX,JMAX,KMAX)
  16       DIMENSION GWRK(IMAX,4)
  17 C
  18 C     Rearrange the input data array so that we can do the main loop
  19 C     as a matrix * vector operation with vector length 4*KMAX.
  20 C     This gets the time consumption in this subroutine from a total of
  21 C     nearly 50% down to 7%.
  22 C     Probably one can improve the stacking of arrays and even get
  23 C     VLEN=8*KMAX. But not tried yet.
  24 C
  25 C
  26 C     Note we set distinct signs, because we wont to collapse 4
  27 C     different assignments into one
  28 !CDIR NOVECTOR
  29       DO K=1,KMAX
  30 !CDIR NODEP
  31       DO L=1,MNWAV
  32       Q(K,1,L)=QPSIX(1,K,L)
  33       Q(K,2,L)=QPSIX(2,K,L)
  34       Q(K,3,L)=-QCHIX(1,K,L)
  35       Q(K,4,L)=-QCHIX(2,K,L)
  36       QR(K,4,L)=-QPSIX(1,K,L)
  37       QR(K,3,L)=QPSIX(2,K,L)
  38       QR(K,2,L)=-QCHIX(1,K,L)
  39       QR(K,1,L)=QCHIX(2,K,L)
  40       ENDDO
  41       ENDDO
  42 C
  43 c*nec MNWAV=MNWAV
  44 C*NEC 1999/05/12 start
  45       CALL RESET(gux ,IMAX*JMAX*KMAX)
  46       CALL RESET(gvx ,IMAX*JMAX*KMAX)
  47 C     DO I=1,IMAX*JMAX*KMAX
  48 Cc*nec CALL RESET(gu(,,)  ,IMAX*JMAX*KMAX)
  49 C     gu(1,I,1)=0.0
  50 Cc*nec CALL RESET(gv(,,)  ,IMAX*JMAX*KMAX)
  51 C     gv(1,I,1)=0.0
  52 C     ENDDO
  53 Cc*nec
  54 C*NEC 1999/05/12 end
  55 C
  56
  57
  58       DO 150 J=1,JMAXHF
  59       JM=       J
  60       JP=JMAX+1-J
  61       JMC=1
  62       JPC=2
  63       IF ( JM.EQ.JP) JPC=1
  64       CALL RESET(GU,KMAX*4*MEND1*2)
  65       L =0
  66       DO 120 M=1,MEND1
  67       NMAX=MIN(JEND1+1-M,NEND1)
  68       QM  =FLOAT(M-1)
  69       DO 140 N=1,NMAX,2
  70       DO K=1,KMAX*4
  71       GU(K,1,M,JMC)=GU(K,1,M,JMC)-QM*QR(K,1,L+N)* PNM(L+N,J)
  72 C-COLL      GU(K,2,M,JMC)=GU(K,2,M,JMC)+QM*QR(K,2,L+N)* PNM(L+N,J)
  73 C-COLL      GU(K,3,M,JMC)=GU(K,3,M,JMC)-QM*QR(K,3,L+N)* PNM(L+N,J)
  74 C-COLL      GU(K,4,M,JMC)=GU(K,4,M,JMC)+QM*QR(K,4,L+N)* PNM(L+N,J)
  75       ENDDO
  76   140 CONTINUE
  77       DO 160 N=1,NMAX,2
  78       DO K=1,KMAX*4
  79       GU(K,1,M,JPC)=GU(K,1,M,JPC)+   Q(K,1,L+N)*DPNM(L+N,J)
  80 C-COLL      GU(K,2,M,JPC)=GU(K,2,M,JPC)+   Q(K,2,L+N)*DPNM(L+N,J)
  81 C-COLL      GU(K,3,M,JPC)=GU(K,3,M,JPC)-   Q(K,3,L+N)*DPNM(L+N,J)
  82 C-COLL      GU(K,4,M,JPC)=GU(K,4,M,JPC)-   Q(K,4,L+N)*DPNM(L+N,J)
  83       ENDDO
  84   160 CONTINUE
  85       DO 180 N=2,NMAX,2
  86       DO K=1,KMAX*4
  87       GU(K,1,M,JPC)=GU(K,1,M,JPC)-QM*QR(K,1,L+N)* PNM(L+N,J)
  88 C-COLL      GU(K,2,M,JPC)=GU(K,2,M,JPC)+QM*QR(K,2,L+N)* PNM(L+N,J)
  89 C-COLL      GU(K,3,M,JPC)=GU(K,3,M,JPC)-QM*QR(K,3,L+N)* PNM(L+N,J)
  90 C-COLL      GU(K,4,M,JPC)=GU(K,4,M,JPC)+QM*QR(K,4,L+N)* PNM(L+N,J)
  91       ENDDO
  92   180 CONTINUE
  93       DO 200 N=2,NMAX,2
  94       DO K=1,KMAX*4
  95       GU(K,1,M,JMC)=GU(K,1,M,JMC)+   Q(K,1,L+N)*DPNM(L+N,J)
  96 C-COLL      GU(K,2,M,JMC)=GU(K,2,M,JMC)+   Q(K,2,L+N)*DPNM(L+N,J)
  97 C-COLL      GU(K,3,M,JMC)=GU(K,3,M,JMC)-   Q(K,3,L+N)*DPNM(L+N,J)
  98 C-COLL      GU(K,4,M,JMC)=GU(K,4,M,JMC)-   Q(K,4,L+N)*DPNM(L+N,J)
  99       ENDDO
 100   200 CONTINUE
 101       L=L+NMAX
 102   120 CONTINUE
 103   100 CONTINUE
 104 C
 105 !CDIR NOVECTOR
 106         DO K=1,KMAX
 107 !CDIR NODEP
 108         DO M=1,MEND1
 109         GUX(2*M-1,JM,K)=GU(K,1,M,JMC)
 110         GUX(2*M  ,JM,K)=GU(K,2,M,JMC)
 111         GVX(2*M-1,JM,K)=GU(K,3,M,JMC)
 112         GVX(2*M  ,JM,K)=GU(K,4,M,JMC)
 113         GUX(2*M-1,JP,K)=GU(K,1,M,JPC)
 114         GUX(2*M  ,JP,K)=GU(K,2,M,JPC)
 115         GVX(2*M-1,JP,K)=GU(K,3,M,JPC)
 116         GVX(2*M  ,JP,K)=GU(K,4,M,JPC)
 117         ENDDO
 118         ENDDO
 119 C
 120   150 CONTINUE
 121 C
 122       DO 300 K=1,KMAX
 123       DO 300 J=1,JMAXHF
 124       JM=       J
 125       JP=JMAX+1-J
 126
 127       IF(MOD(JMAX,2).EQ.1.AND.J.EQ.JMAXHF) GO TO 300
 128       DO 220 M=1,MEND1*2
 129       GWRKM1=GUX(M,JM,K)+GUX(M,JP,K)
 130       GWRKM2=GUX(M,JM,K)-GUX(M,JP,K)
 131       GWRKM3=GVX(M,JM,K)+GVX(M,JP,K)
 132       GWRKM4=GVX(M,JM,K)-GVX(M,JP,K)
 133       GUX  (M,JM,K)=GWRKM1
 134       GUX  (M,JP,K)=GWRKM2
 135       GVX  (M,JM,K)=GWRKM3
 136       GVX  (M,JP,K)=GWRKM4
 137   220 CONTINUE
 138   300 CONTINUE
 139 C
 140       RETURN
 141       END SUBROUTINE LGNUV
 142