V3FIT
fourp.f
1  SUBROUTINE fourp (grpmn, grp, istore, istart, iend, ndim)
2  USE vacmod
3  USE parallel_include_module
4  USE timer_sub
5  IMPLICIT NONE
6 C-----------------------------------------------
7 C D u m m y A r g u m e n t s
8 C-----------------------------------------------
9  INTEGER, INTENT(inout) :: istart
10  INTEGER, INTENT(in) :: iend, istore, ndim
11  REAL(dp), INTENT(in) :: grp(nuv,istore)
12  REAL(dp), INTENT(inout) :: grpmn(0:mf,-nf:nf,ndim,nuv3)
13 C-----------------------------------------------
14 C L o c a l V a r i a b l e s
15 C-----------------------------------------------
16  INTEGER :: n, kv, ku, ip, iuv, m, ireflect, isym
17  REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: g1, g2
18  REAL(dp), ALLOCATABLE :: kernel(:), gcos(:),gsin(:)
19  REAL(dp) :: cosm, sinm, cosn, sinn, tfourpon, tfourpoff
20 C-----------------------------------------------
21 !
22 ! PERFORM KV (TOROIDAL ANGLE) TRANSFORM (OVER UNPRIMED MESH IN EQ. 2.14)
23 ! THUS, THE (m,n) INDEX HERE CORRESPONDS TO THE FIRST INDEX OF AMATRIX
24 ! NOTE: THE .5 FACTOR (IN COSN,SINN) ACCOUNTS FOR THE SUM IN KERNELM
25 ! ON ENTRY THE FIRST TIME, GRPMN IS SIN,COS * Kmn(analytic)
26 !
27 ! THE 3rd INDEX OF GRPMN IS THE PRIMED U,V MESH COORDINATE
28 !
29  CALL second0(tfourpon)
30  ALLOCATE (g1(istore,nu2,0:nf,ndim), g2(istore,nu2,0:nf,ndim),
31  1 kernel(istore), gcos(istore), gsin(istore), stat=m)
32  IF (m .ne. 0) stop 'Allocation error in fourp'
33 
34  g1 = 0
35  g2 = 0
36 
37  DO n = 0, nf
38  DO kv = 1,nv
39  cosn = p5*onp*cosv(n,kv)
40  sinn = p5*onp*sinv(n,kv)
41  iuv = kv
42  DO ku = 1,nu2
43  ireflect = imirr(iuv)
44  DO isym = 1, ndim
45  DO ip = 1,istore
46  IF (isym .EQ. 1) THEN
47  kernel(ip) =
48  1 grp(iuv,ip) - grp(ireflect,ip) !anti-symmetric part (u,v -> -u,-v)
49  ELSE IF (isym .EQ. 2) THEN
50  kernel(ip) =
51  1 grp(iuv,ip) + grp(ireflect,ip) !symmetric part
52  END IF
53  g1(ip,ku,n,isym)=g1(ip,ku,n,isym) + cosn*kernel(ip)
54  g2(ip,ku,n,isym)=g2(ip,ku,n,isym) + sinn*kernel(ip)
55  END DO
56  END DO
57  iuv = iuv + nv
58  END DO
59  END DO
60  END DO
61 
62 !
63 ! PERFORM KU (POLOIDAL ANGLE) TRANFORM [COMPLETE SIN(mu-nv) / COS(mu-nv) TRANSFORM]
64 !
65 
66  DO m = 0,mf
67  DO ku = 1,nu2
68  DO isym = 1, ndim
69  IF (isym .EQ. 1) THEN
70  cosm = -cosui(m,ku)
71  sinm = sinui(m,ku)
72  ELSE IF (isym .EQ. 2) THEN
73  sinm = cosui(m,ku)
74  cosm = sinui(m,ku)
75  END IF
76  DO n= 0,nf
77  DO ip = 1,istore
78  gcos(ip) = g1(ip,ku,n,isym)*sinm
79  gsin(ip) = g2(ip,ku,n,isym)*cosm
80  grpmn(m,n,isym,ip+istart) =
81  1 grpmn(m,n,isym,ip+istart) + gcos(ip) + gsin(ip)
82  END DO
83 
84  IF (n.NE.0 .AND. m.NE.0) THEN !zero for m=0,n<0 (SPH082515)
85  DO ip = 1,istore
86  grpmn(m,-n,isym,ip+istart) =
87  1 grpmn(m,-n,isym,ip+istart)
88  2 + gcos(ip) - gsin(ip)
89  END DO
90  ENDIF
91  END DO
92  END DO
93  END DO
94  END DO
95 
96  istart = iend
97 
98  DEALLOCATE (g1, g2, kernel, gcos, gsin, stat=m)
99 
100  CALL second0(tfourpoff)
101  timer_vac(tfourp) = timer_vac(tfourp) + (tfourpoff-tfourpon)
102  fourp_time = timer_vac(tfourp)
103 
104  END SUBROUTINE fourp