1      subroutine argos_pme_start(a,m,imffti,nodpmi,
2     + ngxi,ngyi,ngzi,nwm,nwa,nsa,ictrl,nbgeti)
3c $Id$
4      implicit none
5c
6      integer nodpmi,ngxi,ngyi,ngzi,imffti,nwm,nwa,nsa,m
7      integer ictrl,nbgeti
8      real*8 a
9c
10      integer mem
11c
12#include "argos_pme_common.fh"
13#include "mafdecls.fh"
14#include "global.fh"
15c
16      me=ga_nodeid()
17      np=ga_nnodes()
18c
19      pi=four*atan(one)
20      twopi=two*pi
21      alpha=a
22      morder=m
23      nodpme=nodpmi
24      icntrl=ictrl
25      nbget=nbgeti
26c
27      imfft=imffti
28      lcorr(1)=.false.
29      lcorr(2)=.false.
30      lcorr(3)=.false.
31c
32      mwa=nwa
33      mwm=nwm
34      msa=nsa
35c
36      ngx=ngxi
37      ngy=ngyi
38      ngz=ngzi
39      ngmax=max(ngx,ngy,ngz)
40      mgx=ngx
41      mgy=ngy
42      mgz=(ngz/nodpme)+1
43      ngrx=ngx+morder
44      ngry=ngy+morder
45      ngrz=ngz
46      mgrx=ngrx
47      mgry=ngry
48      mgrz=mgz
49      if(nodpme*mgz.lt.ngz)
50     + call md_abort('Inconsistent number of pme nodes',0)
51c
52c     allocate memory for spline coefficients
53c
54      if(.not.ma_push_get(mt_dbl,3*ngmax,'bmod',l_bmod,i_bmod))
55     + call md_abort('Failed to allocate bmod',0)
56      if(.not.ma_push_get(mt_dbl,ngmax,'barr',l_barr,i_barr))
57     + call md_abort('Failed to allocate barr',0)
58c
59c     allocate memory for the grids
60c
61      mem=2*mgx*mgy*mgz
62      if(.not.ma_push_get(mt_dbl,mem,'grid1',l_grd1,i_grd1))
63     + call md_abort('Failed to allocate grid1',0)
64      if(.not.ma_push_get(mt_dbl,mem,'grid2',l_grd2,i_grd2))
65     + call md_abort('Failed to allocate grid2',0)
66      if(.not.ma_push_get(mt_dbl,mgrx*mgry*mgz,'grid',l_grd,i_grd))
67     + call md_abort('Failed to allocate grid',0)
68      if(nbget.gt.0) then
69      if(.not.ma_push_get(mt_dbl,mgrx*mgry*mgz,'gridt',l_grdt,i_grdt))
70     + call md_abort('Failed to allocate gridt',0)
71      if(.not.ma_push_get(mt_int,mgz,'gridh',l_grdh,i_grdh))
72     + call md_abort('Failed to allocate gridh',0)
73      else
74      if(.not.ma_push_get(mt_dbl,1,'gridt',l_grdt,i_grdt))
75     + call md_abort('Failed to allocate gridt',0)
76      if(.not.ma_push_get(mt_int,1,'gridh',l_grdh,i_grdh))
77     + call md_abort('Failed to allocate gridh',0)
78      endif
79c
80c     allocate memory for node arrays
81c
82      if(.not.ma_push_get(mt_int,np,'lnode',l_lnod,i_lnod))
83     + call md_abort('Failed to allocate lnode',0)
84      if(.not.ma_push_get(mt_int,np,'kfrom',l_kfr,i_kfr))
85     + call md_abort('Failed to allocate kfrom',0)
86      if(.not.ma_push_get(mt_int,np,'kto',l_kto,i_kto))
87     + call md_abort('Failed to allocate kto',0)
88      if(.not.ma_push_get(mt_int,np,'nodep',l_nodp,i_nodp))
89     + call md_abort('Failed to allocate nodep',0)
90c
91      if(.not.ma_push_get(mt_int,ngz,'knode',l_knod,i_knod))
92     + call md_abort('Failed to allocate knode',0)
93c
94      if(.not.ma_push_get(mt_log,mgz*np,'lsldo',l_lsld,i_lsld))
95     + call md_abort('Failed to allocate ldldo',0)
96      if(.not.ma_push_get(mt_int,4*mgz*np,'slmax',l_slmax,i_slmax))
97     + call md_abort('Failed to allocate slmax',0)
98c
99c     allocate memory for fft node maps
100c
101      mem=3*max(ngx,ngy,ngz)
102      if(.not.ma_push_get(mt_int,mem,'map1',l_map1,i_map1))
103     + call md_abort('Failed to allocate map1',0)
104      if(.not.ma_push_get(mt_int,mem,'map2',l_map2,i_map2))
105     + call md_abort('Failed to allocate map2',0)
106c
107c     allocate memory for slab arrays
108c
109      mem=mgz*np
110      if(.not.ma_push_get(mt_int,mem,'slab',l_slab,i_slab))
111     + call md_abort('Failed to allocate slab',0)
112c
113c     create the global arrays for the slabs
114c
115      call ga_create_list(np*mgrx,mgry,'sl',mgrx,mgry,mgz,lslab)
116c
117c     create the flag array
118c
119      if(.not.ga_create(mt_int,np,5,'flg',1,5,ga_flg))
120     + call md_abort('Failed to allocate global array flg',0)
121      call argos_pme_flag(0,0,me)
122      call argos_pme_flag(1,0,me)
123c
124c     select the fft
125c
126      call argos_pme_select(zero)
127c
128c     test the fft
129c
130      if(lpnode)
131     + call argos_pme_fftest(dbl_mb(i_grd1),dbl_mb(i_grd2),
132     + int_mb(i_nodp))
133c
134      call argos_pme_coeff(dbl_mb(i_bmod),dbl_mb(i_barr))
135c
136      return
137      end
138