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