1 SUBROUTINE analyt (grpmn, bvec, ivacskip, ndim)
3 USE parallel_include_module
9 INTEGER,
INTENT(IN) :: ivacskip, ndim
10 REAL(dp),
INTENT(OUT) :: grpmn(mnpd2,nuv3)
11 REAL(dp),
INTENT(OUT) :: bvec(mnpd,ndim)
15 INTEGER :: l, n, m, i, q, j, k, ll, blksize, mn
16 REAL(dp),
DIMENSION(:),
ALLOCATABLE ::
17 1 r0p, r1p, r0m, r1m, sqrtc, sqrta, tlp2, tlp1, tlp, tlm2,
18 2 tlm1, tlm, adp, adm, cma, ra1p, ra1m, slm, slp, tlpm, slpm,
19 3 delt1u, azp1u, azm1u, cma11u, sqad1u, sqad2u
20 REAL(dp) :: fl, fl1, fl2, sign1, tanalon, tanaloff
24 ALLOCATE (r0p(nuv3), r1p(nuv3), r0m(nuv3), r1m(nuv3),
25 1 sqrtc(nuv3), sqrta(nuv3), tlp2(nuv3), tlp1(nuv3),
26 2 tlp(nuv3), tlm2(nuv3), tlm1(nuv3), tlm(nuv3), adp(nuv3),
27 3 adm(nuv3), cma(nuv3), ra1p(nuv3), ra1m(nuv3), slm(nuv3),
28 4 slp(nuv3), tlpm(nuv3), slpm(nuv3), delt1u(nuv3),
29 5 azp1u(nuv3), azm1u(nuv3), cma11u(nuv3), sqad1u(nuv3),
30 6 sqad2u(nuv3), stat = l)
31 IF (l .ne. 0) stop
'Allocation error in SUBROUTINE analyt'
76 DO k = nuv3min, nuv3max
77 adp(k) = guu_b(k) + guv_b(k) + gvv_b(k)
78 adm(k) = guu_b(k) - guv_b(k) + gvv_b(k)
79 cma(k) = gvv_b(k) - guu_b(k)
80 sqrtc(k) = two*sqrt(gvv_b(k))
81 sqrta(k) = two*sqrt(guu_b(k))
84 IF (ivacskip .EQ. 0)
THEN
86 grpmn(:,nuv3min:nuv3max) = 0
88 DO k = nuv3min, nuv3max
89 delt1u(k) = adp(k)*adm(k) - cma(k)*cma(k)
90 azp1u(k) = auu(k) + auv(k) + avv(k)
91 azm1u(k) = auu(k) - auv(k) + avv(k)
92 cma11u(k)= avv(k) - auu(k)
93 r1p(k) = (azp1u(k)*(delt1u(k) - cma(k)*cma(k))/adp(k)
94 1 - azm1u(k)*adp(k) + two*cma11u(k)*cma(k))/delt1u(k)
95 r1m(k) = (azm1u(k)* (delt1u(k) - cma(k)*cma(k))/adm(k)
96 1 - azp1u(k)*adm(k) + two*cma11u(k)*cma(k))/delt1u(k)
97 r0p(k) = (-azp1u(k)*adm(k)*cma(k)/adp(k) - azm1u(k)*cma(k)
98 1 + two*cma11u(k)*adm(k))/delt1u(k)
99 r0m(k) = (-azm1u(k)*adp(k)*cma(k)/adm(k) - azp1u(k)*cma(k)
100 1 + two*cma11u(k)*adp(k))/delt1u(k)
101 ra1p(k) = azp1u(k)/adp(k)
102 ra1m(k) = azm1u(k)/adm(k)
117 DO k = nuv3min,nuv3max
118 sqad1u(k) = sqrt(adp(k))
119 sqad2u(k) = sqrt(adm(k))
122 tlp(k) = one/sqad1u(k)*log((sqad1u(k)*sqrtc(k)
123 1 + adp(k) + cma(k))/(sqad1u(k)*sqrta(k)
124 2 - adp(k) + cma(k)))
125 tlm(k) = one/sqad2u(k)*log((sqad2u(k)*sqrtc(k)
126 1 + adm(k) + cma(k))/(sqad2u(k)*sqrta(k)
127 2 - adm(k) + cma(k)))
128 tlpm(k) = tlp(k) + tlm(k)
138 lloop:
DO l = 0, mf + nf
144 IF (ivacskip .eq. 0)
THEN
145 DO k = nuv3min,nuv3max
146 slp(k) = (r1p(k)*fl + ra1p(k))*tlp(k) + r0p(k)*fl*tlp1(k)
147 1 - (r1p(k) + r0p(k))/sqrtc(k)
148 2 + sign1*(r0p(k) - r1p(k))/sqrta(k)
149 slm(k) = (r1m(k)*fl + ra1m(k))*tlm(k) + r0m(k)*fl*tlm1(k)
150 1 - (r1m(k) + r0m(k))/sqrtc(k)
151 2 + sign1*(r0m(k) - r1m(k))/sqrta(k)
152 slpm(k) = slp(k) + slm(k)
162 mn = m + mf1*(n+nf) + 1
164 mn = m + mf1*(nf-n) + 1
168 IF (cmns(l,m,n) .eq. zero) cycle
170 IF (n.eq.0 .or. m.eq.0)
THEN
174 CALL analysum (grpmn, bvec, slpm, tlpm, m, n, l,
181 CALL analysum2 (grpmn, bvec, slm, tlm, slp, tlp,
182 1 m, n, l, ivacskip, ndim)
194 DO k = nuv3min, nuv3max
199 tlp(k) = ((sqrtc(k) + sign1*sqrta(k)) - fl2*
200 1 cma(k)*tlp1(k) - fl*adm(k)*tlp2(k))/(adp(k)*fl1)
201 tlm(k) = ((sqrtc(k) + sign1*sqrta(k)) - fl2*
202 1 cma(k)*tlm1(k) - fl*adp(k)*tlm2(k))/(adm(k)*fl1)
203 tlpm(k) = tlp(k) + tlm(k)
208 DEALLOCATE (r0p, r1p, r0m, r1m, sqrtc, sqrta, tlp2, tlp1,
209 1 tlp, tlm2, tlm1, tlm, adp, adm, cma, ra1p, ra1m, slm,
210 2 slp, tlpm, slpm, delt1u, azp1u, azm1u, cma11u, sqad1u,
213 CALL second0(tanaloff)
214 timer_vac(tanal) = timer_vac(tanal) + (tanaloff-tanalon)
215 analyt_time = timer_vac(tanal)
218 END SUBROUTINE analyt