1 logical function argos_prep_mksgm(lfnout,lfnfrg,filfrg, 2 + lfnsgm,filsgm) 3c 4c $Id$ 5c 6c function to make segment file 7c 8c in : lfnfrg = fragment file logical file number 9c lfnsgm = segment file logical file number 10c lfnout = output file logical file number 11c 12 implicit none 13c 14#include "mafdecls.fh" 15#include "util.fh" 16#include "argos_prep_common.fh" 17c 18 logical argos_prep_frgsiz,argos_prep_frgrd,argos_prep_ang, 19 + argos_prep_dih,argos_prep_imp 20 logical argos_prep_dihsel,argos_prep_dihimp,argos_prep_wrtsgm 21 external argos_prep_frgsiz,argos_prep_frgrd,argos_prep_ang, 22 + argos_prep_dih,argos_prep_imp 23 external argos_prep_dihsel,argos_prep_dihimp,argos_prep_wrtsgm 24c 25 integer lfnout,lfnfrg,lfnsgm 26 character*255 filfrg,filsgm 27c 28 integer length 29 integer matm,mbnd,mang,mdih,mimp,mzmat 30 integer natm,nbnd,nang,ndih,nimp,nzmat 31c 32 integer l_latm,i_latm,l_catm,i_catm,l_qatm,i_qatm 33 integer l_bnd,i_bnd,l_ang,i_ang,l_dih,i_dih,l_imp,i_imp 34 integer i_izmat,l_izmat,i_zmat,l_zmat,l_fil,i_fil 35c 36 integer nparms,ipardef 37c 38 length=index(filsgm,' ')-1 39c 40 if(util_print('where',print_debug)) then 41 write(lfnout,2000) filsgm(1:length) 42 2000 format(//,'SEGMENT FILE ',a) 43 endif 44c 45 if(.not.argos_prep_frgsiz(lfnfrg,filfrg,lfnout,natm,nbnd,nzmat, 46 + nparms,ipardef)) 47 + call md_abort('argos_prep_frgsiz failed',9999) 48c 49c allocate memory for bonds, angles, torsions and impropers 50c --------------------------------------------------------- 51c 52 matm=natm 53 mbnd=4*matm 54 if(mbnd.lt.nbnd) mbnd=nbnd 55 mang=6*matm 56 mdih=12*matm 57 mimp=matm 58 nang=0 59 ndih=0 60 nimp=0 61 mzmat=nzmat+1 62c 63c allocate memory for atom list 64c ----------------------------- 65c 66c integer latm(1,matm) : 67c 2 : 68c 3 : 69c 4 : 70c 5 : 71c 72 if(.not.ma_push_get(mt_int,6*matm,'latm',l_latm,i_latm)) 73 + call md_abort('mksgm: Memory allocation failed for latm',9999) 74c 75c char*255 fil 76c 77 if(.not.ma_push_get(mt_byte,255*nparms,'fil',l_fil,i_fil)) 78 + call md_abort('mksgm: Memory allocation failed for fil',9999) 79c 80c char*6 catm(1,matm) : atom name 81c 2 : atom type 82c 83 if(.not.ma_push_get(mt_byte,6*(nparms+1)*matm,'catm', 84 + l_catm,i_catm)) 85 + call md_abort('mksgm: Memory allocation failed for catm',9999) 86c 87c real*8 qatm(1,matm) : partial atomic charges 88c 2 : polarizabilities 89c 90 if(.not.ma_push_get(mt_dbl,2*nparms*matm,'qatm',l_qatm,i_qatm)) 91 + call md_abort('mksgm: Memory allocation failed for qatm',9999) 92c 93c integer lbnd(1:2,mbnd) : bond indices 94c 95 if(.not.ma_push_get(mt_int,2*mbnd,'bnd',l_bnd,i_bnd)) 96 + call md_abort('mksgm: Memory allocation failed for bnd',9999) 97c 98c integer lang(1:3,mang) : angle indices 99c 100 if(.not.ma_push_get(mt_int,3*mang,'ang',l_ang,i_ang)) 101 + call md_abort('mksgm: Memory allocation failed for ang',9999) 102c 103c integer ldih(1:4,mdih) : torsion indices 104c 105 if(.not.ma_push_get(mt_int,4*mdih,'dih',l_dih,i_dih)) 106 + call md_abort('mksgm: Memory allocation failed for dih',9999) 107c 108c integer limp(1:4,mimp) : improper torsion indices 109c 110 if(.not.ma_push_get(mt_int,4*mimp,'imp',l_imp,i_imp)) 111 + call md_abort('mksgm: Memory allocation failed for imp',9999) 112c 113 if(mzmat.gt.0) then 114 if(.not.ma_push_get(mt_int,4*mzmat,'izmat',l_izmat,i_izmat)) 115 + call md_abort('mksgm: Memory allocation failed for izmat',mzmat) 116 if(.not.ma_push_get(mt_dbl,3*mzmat,'zmat',l_zmat,i_zmat)) 117 + call md_abort('mksgm: Memory allocation failed for zmat',mzmat) 118 endif 119c 120c read atom list and bond list from fragment file 121c ----------------------------------------------- 122c 123 if(.not.argos_prep_frgrd(lfnfrg,filfrg,lfnout,nparms,nparms+1, 124 + int_mb(i_latm),byte_mb(i_catm),dbl_mb(i_qatm),matm,natm, 125 + int_mb(i_bnd),mbnd,nbnd,int_mb(i_izmat), 126 + dbl_mb(i_zmat),mzmat,nzmat,byte_mb(i_fil))) 127 + call md_abort('mksgm: argos_prep_frgrd failed',9999) 128c 129c make the angle list 130c ------------------- 131c 132 if(.not.argos_prep_ang(int_mb(i_bnd),mbnd,nbnd, 133 + int_mb(i_ang),mang,nang)) 134 + call md_abort('mksgm: argos_prep_ang failed',9999) 135c 136c make the dihedral list 137c ---------------------- 138c 139 if(.not.argos_prep_dih(int_mb(i_ang),mang,nang, 140 + int_mb(i_dih),mdih,ndih)) 141 + call md_abort('mksgm: argos_prep_dih failed',9999) 142c 143c make the improper list 144c ---------------------- 145c 146 if(.not.argos_prep_imp(int_mb(i_latm),matm,natm, 147 + int_mb(i_bnd),mbnd,nbnd,int_mb(i_imp),mimp,nimp)) 148 + call md_abort('mksgm: argos_prep_imp failed',9999) 149c 150c select dihedrals 151c ---------------- 152c 153 if(.not.argos_prep_dihsel(byte_mb(i_catm), 154 + nparms,nparms+1,matm,natm, 155 + int_mb(i_dih),mdih,ndih)) 156 + call md_abort('mksgm: argos_prep_dihsel failed',9999) 157c 158c switch propers to impropers 159c --------------------------- 160c 161 if(.not.argos_prep_dihimp(int_mb(i_latm),matm,natm, 162 + int_mb(i_ang),mang,nang, 163 + int_mb(i_dih),mdih,ndih,int_mb(i_imp),mimp,nimp)) 164 + call md_abort('mksgm: argos_prep_dihsel failed',9999) 165c 166c write segment file 167c ------------------ 168c 169 if(.not.argos_prep_wrtsgm(lfnout,lfnsgm,filsgm,nparms,nparms+1, 170 + int_mb(i_latm),byte_mb(i_catm),dbl_mb(i_qatm),matm,natm, 171 + int_mb(i_bnd),mbnd,nbnd,int_mb(i_ang),mang,nang, 172 + int_mb(i_dih),mdih,ndih,int_mb(i_imp),mimp,nimp, 173 + int_mb(i_izmat),dbl_mb(i_zmat),mzmat,nzmat,ipardef)) 174 + call md_abort('mksgm: argos_prep_wrtsgm failed',9999) 175c 176c deallocate memory 177c ----------------- 178c 179 if(mzmat.gt.0) then 180 if(.not.ma_pop_stack(l_zmat)) 181 + call md_abort('mksgm: Memory deallocation failed for zmat',9999) 182 if(.not.ma_pop_stack(l_izmat)) 183 + call md_abort('mksgm: Memory deallocation failed for izmat',9999) 184 endif 185 if(.not.ma_pop_stack(l_imp)) 186 + call md_abort('mksgm: Memory deallocation failed for imp',9999) 187 if(.not.ma_pop_stack(l_dih)) 188 + call md_abort('mksgm: Memory deallocation failed for dih',9999) 189 if(.not.ma_pop_stack(l_ang)) 190 + call md_abort('mksgm: Memory deallocation failed for ang',9999) 191 if(.not.ma_pop_stack(l_bnd)) 192 + call md_abort('mksgm: Memory deallocation failed for bnd',9999) 193 if(.not.ma_pop_stack(l_qatm)) 194 + call md_abort('mksgm: Memory deallocation failed for qatm',9999) 195 if(.not.ma_pop_stack(l_catm)) 196 + call md_abort('mksgm: Memory deallocation failed for catm',9999) 197 if(.not.ma_pop_stack(l_fil)) 198 + call md_abort('mksgm: Memory deallocation failed for fil',9999) 199 if(.not.ma_pop_stack(l_latm)) 200 + call md_abort('mksgm: Memory deallocation failed for latm',9999) 201c 202 argos_prep_mksgm=.true. 203 return 204c 205 9999 continue 206 argos_prep_mksgm=.false. 207 return 208 end 209 210