1      logical function argos_prep_admin(lfncmd,filcmd,lfnout,lfnfrg)
2c
3c $Id$
4c
5      implicit none
6c
7#include "util.fh"
8#include "mafdecls.fh"
9#include "argos_prep_common.fh"
10c
11      logical argos_prep_frgsiz,argos_prep_frgrd,argos_prep_master
12      external argos_prep_frgsiz,argos_prep_frgrd,argos_prep_master
13c
14      integer lfncmd,lfnout,lfnfrg
15      character*255 filcmd,card,string
16      character*255 dir,file1,file2
17      integer i,length
18      integer natm,nparms,ipardef,nbnd,nzmat,matm,mbnd,mzmat
19      integer l_latm,i_latm,l_catm,i_catm,l_qatm,i_qatm
20      integer l_bnd,i_bnd,l_fil,i_fil
21      integer i_izmat,l_izmat,i_zmat,l_zmat,i_ndx,l_ndx,i_ndx2,l_ndx2
22c
23      logical ladmin
24c
25      ladmin=.false.
26c
27c     check if the command file exists
28c     --------------------------------
29c
30      open(unit=lfncmd,file=filcmd(1:index(filcmd,' ')-1),
31     + form='formatted',status='old',err=99)
32c
33    1 continue
34c
35      read(lfncmd,3000,end=9,err=999) card
36 3000 format(a)
37c
38      if(card(1:6).eq.'master') then
39      ladmin=.true.
40      string=card(8:255)
41      dir='./ '
42      file1=string
43      length=index(string,' ')-1
44      do 2 i=length,1,-1
45      if(string(i:i).eq.'/') then
46      dir=string(1:i)//' '
47      file1=string(i+1:length)//' '
48      goto 3
49      endif
50    2 continue
51    3 continue
52c
53      write(filmst,'(a,a)') dir(1:index(dir,' ')-1),
54     + file1(1:index(file1,' '))
55      length=index(filmst,' ')-1
56c
57      if(.not.argos_prep_frgsiz(lfnmst,filmst,lfnout,
58     + natm,nbnd,nzmat,nparms,ipardef))
59     + call md_abort('Error in argos_prep_admin',0)
60c
61      matm=natm
62      mbnd=2*matm
63      if(mbnd.lt.nbnd) mbnd=nbnd
64      mzmat=nzmat+1
65c
66c     -----------------------------
67c
68c     integer latm(1,matm) :
69c                  2       :
70c                  3       :
71c                  4       :
72c                  5       :
73c
74      if(.not.ma_push_get(mt_int,6*matm,'latm',l_latm,i_latm))
75     + call md_abort('mksgm: Memory allocation failed for latm',9999)
76      if(.not.ma_push_get(mt_int,matm,'ndx',l_ndx,i_ndx))
77     + call md_abort('mksgm: Memory allocation failed for ndx',9999)
78      if(.not.ma_push_get(mt_int,matm,'ndx',l_ndx2,i_ndx2))
79     + call md_abort('mksgm: Memory allocation failed for ndx2',9999)
80c
81c    char*255 fil
82c
83      if(.not.ma_push_get(mt_byte,255*nparms,'fil',l_fil,i_fil))
84     + call md_abort('mksgm: Memory allocation failed for fil',9999)
85c
86c     char*6  catm(1,matm) : atom name
87c                  2       : atom type
88c
89      if(.not.ma_push_get(mt_byte,6*(nparms+1)*matm,'catm',
90     + l_catm,i_catm))
91     + call md_abort('mksgm: Memory allocation failed for catm',9999)
92c
93c     real*8 qatm(1,matm) : partial atomic charges
94c                 2       : polarizabilities
95c
96      if(.not.ma_push_get(mt_dbl,2*nparms*matm,'qatm',l_qatm,i_qatm))
97     + call md_abort('mksgm: Memory allocation failed for qatm',9999)
98c
99c     integer lbnd(1:2,mbnd) : bond indices
100c
101      if(.not.ma_push_get(mt_int,2*mbnd,'bnd',l_bnd,i_bnd))
102     + call md_abort('mksgm: Memory allocation failed for bnd',9999)
103c
104      if(mzmat.gt.0) then
105      if(.not.ma_push_get(mt_int,4*mzmat,'izmat',l_izmat,i_izmat))
106     + call md_abort('mksgm: Memory allocation failed for izmat',mzmat)
107      if(.not.ma_push_get(mt_dbl,3*mzmat,'zmat',l_zmat,i_zmat))
108     + call md_abort('mksgm: Memory allocation failed for zmat',mzmat)
109      endif
110c
111      if(.not.argos_prep_frgrd(lfnmst,filmst,lfnout,nparms,nparms+1,
112     + int_mb(i_latm),byte_mb(i_catm),dbl_mb(i_qatm),matm,natm,
113     + int_mb(i_bnd),mbnd,nbnd,int_mb(i_izmat),
114     + dbl_mb(i_zmat),mzmat,nzmat,byte_mb(i_fil)))
115     + call md_abort('mksgm: argos_prep_frgrd failed',9999)
116c
117      if(.not.argos_prep_master(lfnfrg,lfnout,nparms,nparms+1,
118     + int_mb(i_latm),byte_mb(i_catm),dbl_mb(i_qatm),matm,natm,
119     + int_mb(i_bnd),mbnd,nbnd,int_mb(i_izmat),
120     + dbl_mb(i_zmat),mzmat,nzmat,dir,byte_mb(i_fil),
121     + int_mb(i_ndx),int_mb(i_ndx2)))
122     + call md_abort('mksgm: argos_prep_master failed',9999)
123c
124      if(mzmat.gt.0) then
125      if(.not.ma_pop_stack(l_zmat))
126     + call md_abort('mksgm: Memory deallocation failed for zmat',9999)
127      if(.not.ma_pop_stack(l_izmat))
128     + call md_abort('mksgm: Memory deallocation failed for izmat',9999)
129      endif
130      if(.not.ma_pop_stack(l_bnd))
131     + call md_abort('mksgm: Memory deallocation failed for bnd',9999)
132      if(.not.ma_pop_stack(l_qatm))
133     + call md_abort('mksgm: Memory deallocation failed for qatm',9999)
134      if(.not.ma_pop_stack(l_catm))
135     + call md_abort('mksgm: Memory deallocation failed for catm',9999)
136      if(.not.ma_pop_stack(l_fil))
137     + call md_abort('mksgm: Memory deallocation failed for fil',9999)
138      if(.not.ma_pop_stack(l_ndx2))
139     + call md_abort('mksgm: Memory deallocation failed for ndx',9999)
140      if(.not.ma_pop_stack(l_ndx))
141     + call md_abort('mksgm: Memory deallocation failed for ndx',9999)
142      if(.not.ma_pop_stack(l_latm))
143     + call md_abort('mksgm: Memory deallocation failed for latm',9999)
144c
145      open(unit=lfnmst,file=filmst(1:length),form='formatted',
146     + status='old',err=9999)
147c
148      if(util_print('sequence',print_high)) then
149      write(lfnout,2001) filmst(1:length)
150 2001 format(' Reading master fragment',t40,a,/)
151      endif
152c
153    4 continue
154c
155      read(lfnmst,1000,end=9999,err=9999) card
156 1000 format(a)
157c
158      if(card(1:1).eq.'#'.or.card(1:1).eq.'$') goto 4
159c
160      read(card,1001) natm,nparms,ipardef
161 1001 format(3i5)
162c
163      close(lfnmst,status='keep')
164c
165      endif
166c
167      goto 1
168c
169    9 continue
170      close(unit=lfncmd)
171c
172   99 continue
173  999 continue
174      argos_prep_admin=ladmin
175      return
176 9999 continue
177      call md_abort('Error in argos_prep_master',0)
178      return
179      end
180