1      logical function pre_rdsgm(lfnout,nparms,mparms,
2     + imol,isgm,igrp,
3     + ipgrp,lfnsgm,filsgm,lfnmat,filmat,
4     + latm,catm,qatm,matm,natm,lbnd,rbnd,mbnd,nbnd,
5     + lang,rang,mang,nang,ldih,nfdih,kdih,rdih,mdih,ndih,
6     + limp,kimp,rimp,mimp,nimp,
7     + wcorr,npar,ipardef,itopol)
8c
9c $Id$
10c
11      implicit none
12c
13#include "util.fh"
14#include "pre_common.fh"
15c
16      external loc
17      integer loc
18c
19      integer lfnout,lfnsgm,imol,isgm,igrp,ipgrp,lfnmat,nparms,mparms
20      character*255 filsgm,filmat
21      integer matm,natm,itopol
22      integer latm(11,matm)
23      character*6 catm(mparms,matm)
24      real*8 qatm(nparms,2,matm)
25      integer mbnd,nbnd
26      integer lbnd(4,mbnd)
27      real*8 rbnd(nparms,2,mbnd)
28      integer mang,nang
29      integer lang(5,mang)
30      real*8 rang(nparms,4,mang)
31      integer mdih,ndih
32      integer ldih(6,mdih),nfdih(nparms,mdih),kdih(6,nparms,mdih)
33      real*8 rdih(6,nparms,2,mdih)
34      integer mimp,nimp
35      integer limp(6,mimp),kimp(nparms,mimp)
36      real*8 rimp(nparms,2,mimp)
37      real*8 wcorr(10)
38      real*8 version
39c
40      character*80 card
41      integer i,j,k,l,length,na,jmol,nzmat,npar,ipardef,idhop
42      integer nsatm,nsbnd,nsang,nsdih,nsimp,ld(6),md(10),izm(4)
43      real*8 rd(10,2),zm(3)
44c
45      integer itemp
46      real*8 dtemp
47      character*6 ctemp
48c
49      jmol=imol
50c
51      length=index(filsgm,' ')-1
52      open(unit=lfnsgm,file=filsgm(1:length),form='formatted',
53     + status='old',err=9999)
54c
55      if(util_print('where',print_debug)) then
56      write(lfnout,1110) filsgm(1:length)
57 1110 format('READING SEGMENT FILE ',a)
58      endif
59c
60    1 continue
61      read(lfnsgm,1000) card
62 1000 format(a)
63      if(card(1:1).eq.'#'.or.card(1:1).eq.'$') goto 1
64      read(card,1001,err=9999) version
65 1001 format(f12.6)
66      read(lfnsgm,1002,err=9999)
67     + nsatm,nsbnd,nsang,nsdih,nsimp,nzmat,npar,ipardef
68 1002 format(8i5)
69      if(ipardef.eq.0) ipardef=1
70      if(npar.gt.nparms) call md_abort('Error in number par sets',npar)
71      do 2 i=1,npar
72      read(lfnsgm,1003) wcorr(i)
73 1003 format(f12.6)
74    2 continue
75      do 102 i=npar+1,nparms
76      wcorr(i)=wcorr(npar)
77  102 continue
78c
79      if(natm+nsatm.gt.matm) call md_abort('increase matm',9999)
80      if(nbnd+nsbnd.gt.mbnd) call md_abort('increase mbnd',9999)
81      if(nang+nsang.gt.mang) call md_abort('increase mang',9999)
82      if(ndih+nsdih.gt.mdih) call md_abort('increase mdih',9998)
83      if(nimp+nsimp.gt.mimp) call md_abort('increase mimp',9999)
84c
85c     read the atom list
86c     ------------------
87c
88      na=natm
89      do 3 i=1,nsatm
90      natm=natm+1
91      read(lfnsgm,1004) catm(1,natm),latm(3,natm),latm(4,natm),
92     + latm(10,natm),latm(1,natm),latm(2,natm)
93 1004 format(5x,a6,5i5)
94c      write(*,1004) catm(1,natm),latm(3,natm),latm(4,natm),
95c     + latm(10,natm),latm(1,natm),latm(2,natm)
96      read(lfnsgm,1005) (catm(j+1,natm),qatm(j,1,natm),qatm(j,2,natm),
97     + j=1,npar)
98 1005 format(5x,a6,2f12.6)
99c
100      latm(5,natm)=isgm
101      latm(6,natm)=jmol
102      jmol=iabs(jmol)
103      latm(1,natm)=latm(1,natm)+igrp
104      latm(2,natm)=latm(2,natm)+ipgrp
105c
106      if(isgm.eq.0) then
107      do 4 j=2,npar+1
108      catm(j,natm)(6:6)='w'
109    4 continue
110      endif
111c
112      do 103 j=npar+1,nparms
113      catm(j+1,natm)=catm(npar+1,natm)
114      qatm(j,1,natm)=qatm(npar,1,natm)
115      qatm(j,2,natm)=qatm(npar,2,natm)
116  103 continue
117c
118      idhop=0
119      do 1103 j=1,npar
120      if(catm(j+1,natm)(6:6).ne.'D') idhop=idhop+2**(j-1)
121 1103 continue
122      latm(11,natm)=idhop
123c
124      if(util_print('connectivity',print_debug)) then
125      write(lfnout,1004) catm(1,natm),(latm(j,natm),j=1,4)
126      write(lfnout,1005) (catm(j+1,natm),qatm(j,1,natm),qatm(j,2,natm),
127     + j=1,nparms)
128      endif
129c
130      if(itopol.eq.0.and.ipardef.gt.1) then
131      ctemp=catm(2,natm)
132      catm(2,natm)=catm(1+ipardef,natm)
133      catm(1+ipardef,natm)=ctemp
134      dtemp=qatm(1,1,natm)
135      qatm(1,1,natm)=qatm(ipardef,1,natm)
136      qatm(ipardef,1,natm)=dtemp
137      dtemp=qatm(1,2,natm)
138      qatm(1,2,natm)=qatm(ipardef,2,natm)
139      qatm(ipardef,2,natm)=dtemp
140      endif
141    3 continue
142c
143      igrp=latm(1,natm)
144      ipgrp=latm(2,natm)
145c
146c     read the bond list
147c     ------------------
148c
149      do 5 i=1,nsbnd
150      nbnd=nbnd+1
151      read(lfnsgm,1006) (lbnd(j,nbnd),j=1,4)
152 1006 format(5x,4i5)
153      read(lfnsgm,1007) (rbnd(j,1,nbnd),rbnd(j,2,nbnd),j=1,npar)
154 1007 format(f12.6,e12.5)
155c
156      lbnd(1,nbnd)=lbnd(1,nbnd)+na
157      lbnd(2,nbnd)=lbnd(2,nbnd)+na
158c
159      do 105 j=npar+1,nparms
160      rbnd(j,1,nbnd)=rbnd(npar,1,nbnd)
161      rbnd(j,2,nbnd)=rbnd(npar,2,nbnd)
162  105 continue
163c
164      if(util_print('connectivity',print_debug)) then
165      write(lfnout,1006) (lbnd(j,nbnd),j=1,4)
166      write(lfnout,1007) (rbnd(j,1,nbnd),rbnd(j,2,nbnd),j=1,nparms)
167      endif
168c
169      if(itopol.eq.0.and.ipardef.gt.1) then
170      dtemp=rbnd(1,1,nbnd)
171      rbnd(1,1,nbnd)=rbnd(ipardef,1,nbnd)
172      rbnd(ipardef,1,nbnd)=dtemp
173      dtemp=rbnd(1,2,nbnd)
174      rbnd(1,2,nbnd)=rbnd(ipardef,2,nbnd)
175      rbnd(ipardef,2,nbnd)=dtemp
176      endif
177c
178    5 continue
179c
180c     read the angle list
181c     -------------------
182c
183      do 6 i=1,nsang
184      nang=nang+1
185      read(lfnsgm,1008) (lang(j,nang),j=1,5)
186 1008 format(5x,5i5)
187      if(ffield(1:6).ne.'charmm') then
188      read(lfnsgm,1009) (rang(j,1,nang),rang(j,2,nang),j=1,npar)
189 1009 format(f10.6,e12.5)
190      else
191      read(lfnsgm,1019) (rang(j,1,nang),rang(j,2,nang),
192     + rang(j,3,nang),rang(j,4,nang),j=1,npar)
193 1019 format(2(f10.6,e12.5))
194      endif
195      lang(1,nang)=lang(1,nang)+na
196      lang(2,nang)=lang(2,nang)+na
197      lang(3,nang)=lang(3,nang)+na
198c
199      do 106 j=npar+1,nparms
200      rang(j,1,nbnd)=rang(npar,1,nang)
201      rang(j,2,nbnd)=rang(npar,2,nang)
202      if(ffield(1:6).eq.'charmm') then
203      rang(j,3,nbnd)=rang(npar,3,nang)
204      rang(j,4,nbnd)=rang(npar,4,nang)
205      endif
206  106 continue
207c
208      if(util_print('connectivity',print_debug)) then
209      write(lfnout,1008) (lang(j,nang),j=1,5)
210      if(ffield(1:6).ne.'charmm') then
211      write(lfnout,1009) (rang(j,1,nang),rang(j,2,nang),j=1,nparms)
212      else
213      write(lfnout,1019) (rang(j,1,nang),rang(j,2,nang),
214     + rang(j,3,nang),rang(j,4,nang),j=1,nparms)
215      endif
216      endif
217c
218      if(itopol.eq.0.and.ipardef.gt.1) then
219      dtemp=rang(1,1,nang)
220      rang(1,1,nang)=rang(ipardef,1,nang)
221      rang(ipardef,1,nang)=dtemp
222      dtemp=rang(1,2,nang)
223      rang(1,2,nang)=rang(ipardef,2,nang)
224      rang(ipardef,2,nang)=dtemp
225      if(ffield(1:6).eq.'charmm') then
226      dtemp=rang(1,1,nang)
227      rang(1,3,nang)=rang(ipardef,3,nang)
228      rang(ipardef,3,nang)=dtemp
229      dtemp=rang(1,4,nang)
230      rang(1,4,nang)=rang(ipardef,4,nang)
231      rang(ipardef,4,nang)=dtemp
232      endif
233      endif
234c
235    6 continue
236c
237c     read the torsion list
238c     ---------------------
239c
240      do 7 i=1,nsdih
241      read(lfnsgm,1010) (ld(j),j=1,6)
242 1010 format(5x,6i5)
243      read(lfnsgm,1011) (md(j),rd(j,1),rd(j,2),j=1,npar)
244 1011 format(i3,f10.6,e12.5)
245c
246      if(itopol.eq.0.and.ipardef.gt.1) then
247      itemp=md(1)
248      md(1)=md(ipardef)
249      md(ipardef)=itemp
250      dtemp=rd(1,1)
251      rd(1,1)=rd(ipardef,1)
252      rd(ipardef,1)=dtemp
253      dtemp=rd(1,2)
254      rd(1,2)=rd(ipardef,2)
255      rd(ipardef,2)=dtemp
256      endif
257c
258      l=0
259      do 8 j=1,npar
260      if(md(j).ge.0) l=l+1
261    8 continue
262      if(l.eq.npar) then
263      ndih=ndih+1
264      do 9 j=1,nparms
265      nfdih(j,ndih)=1
266    9 continue
267      do 10 j=1,6
268      ldih(j,ndih)=ld(j)
269   10 continue
270      else
271      do 11 j=1,npar
272      if(md(j).lt.0) nfdih(j,ndih)=nfdih(j,ndih)+1
273   11 continue
274      endif
275c
276      do 12 l=1,nparms
277      do 13 j=1,nparms
278      rdih(nfdih(l,ndih),j,1,ndih)=rd(j,1)
279      rdih(nfdih(l,ndih),j,2,ndih)=rd(j,2)
280      kdih(nfdih(l,ndih),j,ndih)=md(j)
281   13 continue
282   12 continue
283c
284      ldih(1,ndih)=ldih(1,ndih)+na
285      ldih(2,ndih)=ldih(2,ndih)+na
286      ldih(3,ndih)=ldih(3,ndih)+na
287      ldih(4,ndih)=ldih(4,ndih)+na
288c
289      do 107 j=npar+1,nparms
290      nfdih(j,ndih)=nfdih(npar,ndih)
291      do 117 k=1,nfdih(j,ndih)
292      kdih(k,j,ndih)=kdih(k,npar,ndih)
293      rdih(k,j,1,ndih)=rdih(k,npar,1,ndih)
294      rdih(k,j,2,ndih)=rdih(k,npar,2,ndih)
295  117 continue
296  107 continue
297c
298      if(util_print('connectivity',print_debug)) then
299      write(lfnout,1010) (ldih(j,ndih),j=1,6)
300      write(lfnout,1011) ((kdih(l,j,ndih),rdih(l,j,1,ndih),
301     + rdih(l,j,2,ndih),l=1,nfdih(j,ndih)),j=1,nparms)
302      endif
303c
304    7 continue
305c
306c     read the improper torsion list
307c     ------------------------------
308c
309      do 14 i=1,nsimp
310      nimp=nimp+1
311      if(ffield(1:5).eq.'amber') then
312      read(lfnsgm,1012) limp(2,nimp),limp(3,nimp),limp(1,nimp),
313     + (limp(j,nimp),j=4,6)
314      else
315      read(lfnsgm,1012) (limp(j,nimp),j=1,6)
316      endif
317 1012 format(5x,6i5)
318      read(lfnsgm,1013) (kimp(j,nimp),rimp(j,1,nimp),
319     + rimp(j,2,nimp),j=1,npar)
320 1013 format(i3,f10.6,e12.5)
321c
322      limp(1,nimp)=limp(1,nimp)+na
323      limp(2,nimp)=limp(2,nimp)+na
324      limp(3,nimp)=limp(3,nimp)+na
325      limp(4,nimp)=limp(4,nimp)+na
326c
327      do 114 j=npar+1,nparms
328      kimp(j,nimp)=kimp(npar,nimp)
329      rimp(j,1,nimp)=rimp(npar,1,nimp)
330      rimp(j,2,nimp)=rimp(npar,2,nimp)
331  114 continue
332c
333      if(util_print('connectivity',print_debug)) then
334      write(lfnout,1012) (limp(j,nimp),j=1,6)
335      write(lfnout,1013) (kimp(j,nimp),rimp(j,1,nimp),
336     + rimp(j,2,nimp),j=1,nparms)
337      endif
338c
339      if(itopol.eq.0.and.ipardef.gt.1) then
340      itemp=kimp(1,nimp)
341      kimp(1,nimp)=kimp(ipardef,nimp)
342      kimp(ipardef,nimp)=itemp
343      dtemp=rimp(1,1,nimp)
344      rimp(1,1,nimp)=rimp(ipardef,1,nimp)
345      rimp(ipardef,1,nimp)=dtemp
346      dtemp=rimp(1,2,nimp)
347      rimp(1,2,nimp)=rimp(ipardef,2,nimp)
348      rimp(ipardef,2,nimp)=dtemp
349      endif
350c
351   14 continue
352c
353c     copy the z-matrix information
354c     -----------------------------
355c
356      if(nzmat.gt.0) then
357      open(unit=lfnmat,file=filmat(1:index(filmat,' ')-1),
358     + form='formatted',status='unknown',err=9999)
359      do 15 i=1,nzmat
360      read(lfnsgm,1014) izm,zm
361      write(lfnmat,1015) izm,zm
362 1014 format(5x,4i5,3f12.6)
363 1015 format(4i5,3f12.6)
364   15 continue
365      close(unit=lfnmat)
366      endif
367c
368      close(unit=lfnsgm)
369c
370      if(util_print('where',print_debug)) then
371      write(lfnout,1120) filsgm(1:length)
372 1120 format('READING SEGMENT FILE ',a,' DONE')
373      endif
374c
375      pre_rdsgm=.true.
376      return
377 9999 continue
378      pre_rdsgm=.false.
379      return
380      end
381
382