LGNUV.inc
References to this file elsewhere.
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