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