?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2010-07-27 Paolo Carlini <paolo.carlini@oracle.com>
[official-gcc/alias-decl.git] / gcc / testsuite / gfortran.dg / g77 / 20010519-1.f
blobc268bf03eb58c1f37481c488b0fd7bc635fe2d5c
1 c { dg-do compile }
2 CHARMM Element source/dimb/nmdimb.src 1.1
3 C.##IF DIMB
4 SUBROUTINE NMDIMB(X,Y,Z,NAT3,BNBND,BIMAG,LNOMA,AMASS,DDS,DDSCR,
5 1 PARDDV,DDV,DDM,PARDDF,DDF,PARDDE,DDEV,DD1BLK,
6 2 DD1BLL,NADD,LRAISE,DD1CMP,INBCMP,JNBCMP,
7 3 NPAR,ATMPAR,ATMPAS,BLATOM,PARDIM,NFREG,NFRET,
8 4 PARFRQ,CUTF1,ITMX,TOLDIM,IUNMOD,IUNRMD,
9 5 LBIG,LSCI,ATMPAD,SAVF,NBOND,IB,JB,DDVALM)
10 C-----------------------------------------------------------------------
11 C 01-Jul-1992 David Perahia, Liliane Mouawad
12 C 15-Dec-1994 Herman van Vlijmen
13 C
14 C This is the main routine for the mixed-basis diagonalization.
15 C See: L.Mouawad and D.Perahia, Biopolymers (1993), 33, 599,
16 C and: D.Perahia and L.Mouawad, Comput. Chem. (1995), 19, 241.
17 C The method iteratively solves the diagonalization of the
18 C Hessian matrix. To save memory space, it uses a compressed
19 C form of the Hessian, which only contains the nonzero elements.
20 C In the diagonalization process, approximate eigenvectors are
21 C mixed with Cartesian coordinates to form a reduced basis. The
22 C Hessian is then diagonalized in the reduced basis. By iterating
23 C over different sets of Cartesian coordinates the method ultimately
24 C converges to the exact eigenvalues and eigenvectors (up to the
25 C requested accuracy).
26 C If no existing basis set is read, an initial basis will be created
27 C which consists of the low-frequency eigenvectors of diagonal blocks
28 C of the Hessian.
29 C-----------------------------------------------------------------------
30 C-----------------------------------------------------------------------
31 C:::##INCLUDE '~/charmm_fcm/impnon.fcm'
32 C..##IF VAX IRIS HPUX IRIS GNU CSPP OS2 GWS CRAY ALPHA
33 IMPLICIT NONE
34 C..##ENDIF
35 C-----------------------------------------------------------------------
36 C-----------------------------------------------------------------------
37 C:::##INCLUDE '~/charmm_fcm/stream.fcm'
38 LOGICAL LOWER,QLONGL
39 INTEGER MXSTRM,POUTU
40 PARAMETER (MXSTRM=20,POUTU=6)
41 INTEGER NSTRM,ISTRM,JSTRM,OUTU,PRNLEV,WRNLEV,IOLEV
42 COMMON /CASE/ LOWER, QLONGL
43 COMMON /STREAM/ NSTRM,ISTRM,JSTRM(MXSTRM),OUTU,PRNLEV,WRNLEV,IOLEV
44 C..##IF SAVEFCM
45 C..##ENDIF
46 C-----------------------------------------------------------------------
47 C-----------------------------------------------------------------------
48 C:::##INCLUDE '~/charmm_fcm/dimens.fcm'
49 INTEGER LARGE,MEDIUM,SMALL,REDUCE
50 C..##IF QUANTA
51 C..##ELIF T3D
52 C..##ELSE
53 PARAMETER (LARGE=60120, MEDIUM=25140, SMALL=6120)
54 C..##ENDIF
55 PARAMETER (REDUCE=15000)
56 INTEGER SIZE
57 C..##IF XLARGE
58 C..##ELIF XXLARGE
59 C..##ELIF LARGE
60 C..##ELIF MEDIUM
61 PARAMETER (SIZE=MEDIUM)
62 C..##ELIF REDUCE
63 C..##ELIF SMALL
64 C..##ELIF XSMALL
65 C..##ENDIF
66 C..##IF MMFF
67 integer MAXDEFI
68 parameter(MAXDEFI=250)
69 INTEGER NAME0,NAMEQ0,NRES0,KRES0
70 PARAMETER (NAME0=4,NAMEQ0=10,NRES0=4,KRES0=4)
71 integer MaxAtN
72 parameter (MaxAtN=55)
73 INTEGER MAXAUX
74 PARAMETER (MAXAUX = 10)
75 C..##ENDIF
76 INTEGER MAXCSP, MAXHSET
77 C..##IF HMCM
78 PARAMETER (MAXHSET = 200)
79 C..##ELSE
80 C..##ENDIF
81 C..##IF REDUCE
82 C..##ELSE
83 PARAMETER (MAXCSP = 500)
84 C..##ENDIF
85 C..##IF HMCM
86 INTEGER MAXHCM,MAXPCM,MAXRCM
87 C...##IF REDUCE
88 C...##ELSE
89 PARAMETER (MAXHCM=500)
90 PARAMETER (MAXPCM=5000)
91 PARAMETER (MAXRCM=2000)
92 C...##ENDIF
93 C..##ENDIF
94 INTEGER MXCMSZ
95 C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE
96 C..##ELSE
97 PARAMETER (MXCMSZ = 5000)
98 C..##ENDIF
99 INTEGER CHRSIZ
100 PARAMETER (CHRSIZ = SIZE)
101 INTEGER MAXATB
102 C..##IF REDUCE
103 C..##ELIF QUANTA
104 C..##ELSE
105 PARAMETER (MAXATB = 200)
106 C..##ENDIF
107 INTEGER MAXVEC
108 C..##IFN VECTOR PARVECT
109 PARAMETER (MAXVEC = 10)
110 C..##ELIF LARGE XLARGE XXLARGE
111 C..##ELIF MEDIUM
112 C..##ELIF SMALL REDUCE
113 C..##ELIF XSMALL
114 C..##ELSE
115 C..##ENDIF
116 INTEGER IATBMX
117 PARAMETER (IATBMX = 8)
118 INTEGER MAXHB
119 C..##IF LARGE XLARGE XXLARGE
120 C..##ELIF MEDIUM
121 PARAMETER (MAXHB = 8000)
122 C..##ELIF SMALL
123 C..##ELIF REDUCE XSMALL
124 C..##ELSE
125 C..##ENDIF
126 INTEGER MAXTRN,MAXSYM
127 C..##IFN NOIMAGES
128 PARAMETER (MAXTRN = 5000)
129 PARAMETER (MAXSYM = 192)
130 C..##ELSE
131 C..##ENDIF
132 C..##IF LONEPAIR (lonepair_max)
133 INTEGER MAXLP,MAXLPH
134 C...##IF REDUCE
135 C...##ELSE
136 PARAMETER (MAXLP = 2000)
137 PARAMETER (MAXLPH = 4000)
138 C...##ENDIF
139 C..##ENDIF (lonepair_max)
140 INTEGER NOEMAX,NOEMX2
141 C..##IF REDUCE
142 C..##ELSE
143 PARAMETER (NOEMAX = 2000)
144 PARAMETER (NOEMX2 = 4000)
145 C..##ENDIF
146 INTEGER MAXATC, MAXCB, MAXCH, MAXCI, MAXCP, MAXCT, MAXITC, MAXNBF
147 C..##IF REDUCE
148 C..##ELIF MMFF CFF
149 PARAMETER (MAXATC = 500, MAXCB = 1500, MAXCH = 3200, MAXCI = 600,
150 & MAXCP = 3000,MAXCT = 15500,MAXITC = 200, MAXNBF=1000)
151 C..##ELIF YAMMP
152 C..##ELIF LARGE
153 C..##ELSE
154 C..##ENDIF
155 INTEGER MAXCN
156 PARAMETER (MAXCN = MAXITC*(MAXITC+1)/2)
157 INTEGER MAXA, MAXAIM, MAXB, MAXT, MAXP
158 INTEGER MAXIMP, MAXNB, MAXPAD, MAXRES
159 INTEGER MAXSEG, MAXGRP
160 C..##IF LARGE XLARGE XXLARGE
161 C..##ELIF MEDIUM
162 PARAMETER (MAXA = SIZE, MAXB = SIZE, MAXT = SIZE,
163 & MAXP = 2*SIZE)
164 PARAMETER (MAXIMP = 9200, MAXNB = 17200, MAXPAD = 8160,
165 & MAXRES = 14000)
166 C...##IF MCSS
167 C...##ELSE
168 PARAMETER (MAXSEG = 1000)
169 C...##ENDIF
170 C..##ELIF SMALL
171 C..##ELIF XSMALL
172 C..##ELIF REDUCE
173 C..##ELSE
174 C..##ENDIF
175 C..##IF NOIMAGES
176 C..##ELSE
177 PARAMETER (MAXAIM = 2*SIZE)
178 PARAMETER (MAXGRP = 2*SIZE/3)
179 C..##ENDIF
180 INTEGER REDMAX,REDMX2
181 C..##IF REDUCE
182 C..##ELSE
183 PARAMETER (REDMAX = 20)
184 PARAMETER (REDMX2 = 80)
185 C..##ENDIF
186 INTEGER MXRTRS, MXRTA, MXRTB, MXRTT, MXRTP, MXRTI, MXRTX,
187 & MXRTHA, MXRTHD, MXRTBL, NICM
188 PARAMETER (MXRTRS = 200, MXRTA = 5000, MXRTB = 5000,
189 & MXRTT = 5000, MXRTP = 5000, MXRTI = 2000,
190 C..##IF YAMMP
191 C..##ELSE
192 & MXRTX = 5000, MXRTHA = 300, MXRTHD = 300,
193 C..##ENDIF
194 & MXRTBL = 5000, NICM = 10)
195 INTEGER NMFTAB, NMCTAB, NMCATM, NSPLIN
196 C..##IF REDUCE
197 C..##ELSE
198 PARAMETER (NMFTAB = 200, NMCTAB = 3, NMCATM = 12000, NSPLIN = 3)
199 C..##ENDIF
200 INTEGER MAXSHK
201 C..##IF XSMALL
202 C..##ELIF REDUCE
203 C..##ELSE
204 PARAMETER (MAXSHK = SIZE*3/4)
205 C..##ENDIF
206 INTEGER SCRMAX
207 C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE
208 C..##ELSE
209 PARAMETER (SCRMAX = 5000)
210 C..##ENDIF
211 C..##IF TSM
212 INTEGER MXPIGG
213 C...##IF REDUCE
214 C...##ELSE
215 PARAMETER (MXPIGG=500)
216 C...##ENDIF
217 INTEGER MXCOLO,MXPUMB
218 PARAMETER (MXCOLO=20,MXPUMB=20)
219 C..##ENDIF
220 C..##IF ADUMB
221 INTEGER MAXUMP, MAXEPA, MAXNUM
222 C...##IF REDUCE
223 C...##ELSE
224 PARAMETER (MAXUMP = 10, MAXNUM = 4)
225 C...##ENDIF
226 C..##ENDIF
227 INTEGER MAXING
228 PARAMETER (MAXING=1000)
229 C..##IF MMFF
230 integer MAX_RINGSIZE, MAX_EACH_SIZE
231 parameter (MAX_RINGSIZE = 20, MAX_EACH_SIZE = 1000)
232 integer MAXPATHS
233 parameter (MAXPATHS = 8000)
234 integer MAX_TO_SEARCH
235 parameter (MAX_TO_SEARCH = 6)
236 C..##ENDIF
237 C-----------------------------------------------------------------------
238 C-----------------------------------------------------------------------
239 C:::##INCLUDE '~/charmm_fcm/number.fcm'
240 REAL(KIND=8) ZERO, ONE, TWO, THREE, FOUR, FIVE, SIX,
241 & SEVEN, EIGHT, NINE, TEN, ELEVEN, TWELVE, THIRTN,
242 & FIFTN, NINETN, TWENTY, THIRTY
243 C..##IF SINGLE
244 C..##ELSE
245 PARAMETER (ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0,
246 & THREE = 3.D0, FOUR = 4.D0, FIVE = 5.D0,
247 & SIX = 6.D0, SEVEN = 7.D0, EIGHT = 8.D0,
248 & NINE = 9.D0, TEN = 10.D0, ELEVEN = 11.D0,
249 & TWELVE = 12.D0, THIRTN = 13.D0, FIFTN = 15.D0,
250 & NINETN = 19.D0, TWENTY = 20.D0, THIRTY = 30.D0)
251 C..##ENDIF
252 REAL(KIND=8) FIFTY, SIXTY, SVNTY2, EIGHTY, NINETY, HUNDRD,
253 & ONE2TY, ONE8TY, THRHUN, THR6TY, NINE99, FIFHUN, THOSND,
254 & FTHSND,MEGA
255 C..##IF SINGLE
256 C..##ELSE
257 PARAMETER (FIFTY = 50.D0, SIXTY = 60.D0, SVNTY2 = 72.D0,
258 & EIGHTY = 80.D0, NINETY = 90.D0, HUNDRD = 100.D0,
259 & ONE2TY = 120.D0, ONE8TY = 180.D0, THRHUN = 300.D0,
260 & THR6TY=360.D0, NINE99 = 999.D0, FIFHUN = 1500.D0,
261 & THOSND = 1000.D0,FTHSND = 5000.D0, MEGA = 1.0D6)
262 C..##ENDIF
263 REAL(KIND=8) MINONE, MINTWO, MINSIX
264 PARAMETER (MINONE = -1.D0, MINTWO = -2.D0, MINSIX = -6.D0)
265 REAL(KIND=8) TENM20,TENM14,TENM8,TENM5,PT0001,PT0005,PT001,PT005,
266 & PT01, PT02, PT05, PTONE, PT125, PT25, SIXTH, THIRD,
267 & PTFOUR, PTSIX, HALF, PT75, PT9999, ONEPT5, TWOPT4
268 C..##IF SINGLE
269 C..##ELSE
270 PARAMETER (TENM20 = 1.0D-20, TENM14 = 1.0D-14, TENM8 = 1.0D-8,
271 & TENM5 = 1.0D-5, PT0001 = 1.0D-4, PT0005 = 5.0D-4,
272 & PT001 = 1.0D-3, PT005 = 5.0D-3, PT01 = 0.01D0,
273 & PT02 = 0.02D0, PT05 = 0.05D0, PTONE = 0.1D0,
274 & PT125 = 0.125D0, SIXTH = ONE/SIX,PT25 = 0.25D0,
275 & THIRD = ONE/THREE,PTFOUR = 0.4D0, HALF = 0.5D0,
276 & PTSIX = 0.6D0, PT75 = 0.75D0, PT9999 = 0.9999D0,
277 & ONEPT5 = 1.5D0, TWOPT4 = 2.4D0)
278 C..##ENDIF
279 REAL(KIND=8) ANUM,FMARK
280 REAL(KIND=8) RSMALL,RBIG
281 C..##IF SINGLE
282 C..##ELSE
283 PARAMETER (ANUM=9999.0D0, FMARK=-999.0D0)
284 PARAMETER (RSMALL=1.0D-10,RBIG=1.0D20)
285 C..##ENDIF
286 REAL(KIND=8) RPRECI,RBIGST
287 C..##IF VAX DEC
288 C..##ELIF IBM
289 C..##ELIF CRAY
290 C..##ELIF ALPHA T3D T3E
291 C..##ELSE
292 C...##IF SINGLE
293 C...##ELSE
294 PARAMETER (RPRECI = 2.22045D-16, RBIGST = 4.49423D+307)
295 C...##ENDIF
296 C..##ENDIF
297 C-----------------------------------------------------------------------
298 C-----------------------------------------------------------------------
299 C:::##INCLUDE '~/charmm_fcm/consta.fcm'
300 REAL(KIND=8) PI,RADDEG,DEGRAD,TWOPI
301 PARAMETER(PI=3.141592653589793D0,TWOPI=2.0D0*PI)
302 PARAMETER (RADDEG=180.0D0/PI)
303 PARAMETER (DEGRAD=PI/180.0D0)
304 REAL(KIND=8) COSMAX
305 PARAMETER (COSMAX=0.9999999999D0)
306 REAL(KIND=8) TIMFAC
307 PARAMETER (TIMFAC=4.88882129D-02)
308 REAL(KIND=8) KBOLTZ
309 PARAMETER (KBOLTZ=1.987191D-03)
310 REAL(KIND=8) CCELEC
311 C..##IF AMBER
312 C..##ELIF DISCOVER
313 C..##ELSE
314 PARAMETER (CCELEC=332.0716D0)
315 C..##ENDIF
316 REAL(KIND=8) CNVFRQ
317 PARAMETER (CNVFRQ=2045.5D0/(2.99793D0*6.28319D0))
318 REAL(KIND=8) SPEEDL
319 PARAMETER (SPEEDL=2.99793D-02)
320 REAL(KIND=8) ATMOSP
321 PARAMETER (ATMOSP=1.4584007D-05)
322 REAL(KIND=8) PATMOS
323 PARAMETER (PATMOS = 1.D0 / ATMOSP )
324 REAL(KIND=8) BOHRR
325 PARAMETER (BOHRR = 0.529177249D0 )
326 REAL(KIND=8) TOKCAL
327 PARAMETER (TOKCAL = 627.5095D0 )
328 C..##IF MMFF
329 REAL(KIND=8) MDAKCAL
330 parameter(MDAKCAL=143.9325D0)
331 C..##ENDIF
332 REAL(KIND=8) DEBYEC
333 PARAMETER ( DEBYEC = 2.541766D0 / BOHRR )
334 REAL(KIND=8) ZEROC
335 PARAMETER ( ZEROC = 298.15D0 )
336 C-----------------------------------------------------------------------
337 C-----------------------------------------------------------------------
338 C:::##INCLUDE '~/charmm_fcm/exfunc.fcm'
339 C..##IF ACE
340 C..##ENDIF
341 C..##IF ADUMB
342 C..##ENDIF
343 CHARACTER(4) GTRMA, NEXTA4, CURRA4
344 CHARACTER(6) NEXTA6
345 CHARACTER(8) NEXTA8
346 CHARACTER(20) NEXT20
347 INTEGER ALLCHR, ALLSTK, ALLHP, DECODI, FIND52,
348 * GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL,
349 * ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF,
350 * INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF,
351 * LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL,
352 * PARNUM, PARINS,
353 * SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE
354 C..##IF ACE
355 * ,GETNNB
356 C..##ENDIF
357 LOGICAL CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE,
358 * HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5,
359 * ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA
360 REAL(KIND=8) DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8,
361 * RANUMB, R8VAL, RETVAL8, SUMVEC
362 C..##IF ADUMB
363 * ,UMFI
364 C..##ENDIF
365 EXTERNAL GTRMA, NEXTA4, CURRA4, NEXTA6, NEXTA8,NEXT20,
366 * ALLCHR, ALLSTK, ALLHP, DECODI, FIND52,
367 * GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL,
368 * ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF,
369 * INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF,
370 * LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL,
371 * PARNUM, PARINS,
372 * SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE,
373 * CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE,
374 * HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5,
375 * ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA,
376 * DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8,
377 * RANUMB, R8VAL, RETVAL8, SUMVEC
378 C..##IF ADUMB
379 * ,UMFI
380 C..##ENDIF
381 C..##IF ACE
382 * ,GETNNB
383 C..##ENDIF
384 C..##IFN NOIMAGES
385 INTEGER IMATOM
386 EXTERNAL IMATOM
387 C..##ENDIF
388 C..##IF MBOND
389 C..##ENDIF
390 C..##IF MMFF
391 INTEGER LEN_TRIM
392 EXTERNAL LEN_TRIM
393 CHARACTER(4) AtName
394 external AtName
395 CHARACTER(8) ElementName
396 external ElementName
397 CHARACTER(10) QNAME
398 external QNAME
399 integer IATTCH, IBORDR, CONN12, CONN13, CONN14
400 integer LEQUIV, LPATH
401 integer nbndx, nbnd2, nbnd3, NTERMA
402 external IATTCH, IBORDR, CONN12, CONN13, CONN14
403 external LEQUIV, LPATH
404 external nbndx, nbnd2, nbnd3, NTERMA
405 external find_loc
406 REAL(KIND=8) vangle, OOPNGL, TORNGL, ElementMass
407 external vangle, OOPNGL, TORNGL, ElementMass
408 C..##ENDIF
409 C-----------------------------------------------------------------------
410 C-----------------------------------------------------------------------
411 C:::##INCLUDE '~/charmm_fcm/stack.fcm'
412 INTEGER STKSIZ
413 C..##IFN UNICOS
414 C...##IF LARGE XLARGE
415 C...##ELIF MEDIUM REDUCE
416 PARAMETER (STKSIZ=4000000)
417 C...##ELIF SMALL
418 C...##ELIF XSMALL
419 C...##ELIF XXLARGE
420 C...##ELSE
421 C...##ENDIF
422 INTEGER LSTUSD,MAXUSD,STACK
423 COMMON /ISTACK/ LSTUSD,MAXUSD,STACK(STKSIZ)
424 C..##ELSE
425 C..##ENDIF
426 C..##IF SAVEFCM
427 C..##ENDIF
428 C-----------------------------------------------------------------------
429 C-----------------------------------------------------------------------
430 C:::##INCLUDE '~/charmm_fcm/heap.fcm'
431 INTEGER HEAPDM
432 C..##IFN UNICOS (unicos)
433 C...##IF XXLARGE (size)
434 C...##ELIF LARGE XLARGE (size)
435 C...##ELIF MEDIUM (size)
436 C....##IF T3D (t3d2)
437 C....##ELIF TERRA (t3d2)
438 C....##ELIF ALPHA (t3d2)
439 C....##ELIF T3E (t3d2)
440 C....##ELSE (t3d2)
441 PARAMETER (HEAPDM=2048000)
442 C....##ENDIF (t3d2)
443 C...##ELIF SMALL (size)
444 C...##ELIF REDUCE (size)
445 C...##ELIF XSMALL (size)
446 C...##ELSE (size)
447 C...##ENDIF (size)
448 INTEGER FREEHP,HEAPSZ,HEAP
449 COMMON /HEAPST/ FREEHP,HEAPSZ,HEAP(HEAPDM)
450 LOGICAL LHEAP(HEAPDM)
451 EQUIVALENCE (LHEAP,HEAP)
452 C..##ELSE (unicos)
453 C..##ENDIF (unicos)
454 C..##IF SAVEFCM (save)
455 C..##ENDIF (save)
456 C-----------------------------------------------------------------------
457 C-----------------------------------------------------------------------
458 C:::##INCLUDE '~/charmm_fcm/fast.fcm'
459 INTEGER IACNB, NITCC, ICUSED, FASTER, LFAST, LMACH, OLMACH
460 INTEGER ICCOUNT, LOWTP, IGCNB, NITCC2
461 INTEGER ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD
462 COMMON /FASTI/ FASTER, LFAST, LMACH, OLMACH, NITCC, NITCC2,
463 & ICUSED(MAXATC), ICCOUNT(MAXATC), LOWTP(MAXATC),
464 & IACNB(MAXAIM), IGCNB(MAXATC),
465 & ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD
466 C..##IF SAVEFCM
467 C..##ENDIF
468 C-----------------------------------------------------------------------
469 C-----------------------------------------------------------------------
470 C:::##INCLUDE '~/charmm_fcm/deriv.fcm'
471 REAL(KIND=8) DX,DY,DZ
472 COMMON /DERIVR/ DX(MAXAIM),DY(MAXAIM),DZ(MAXAIM)
473 C..##IF SAVEFCM
474 C..##ENDIF
475 C-----------------------------------------------------------------------
476 C-----------------------------------------------------------------------
477 C:::##INCLUDE '~/charmm_fcm/energy.fcm'
478 INTEGER LENENP, LENENT, LENENV, LENENA
479 PARAMETER (LENENP = 50, LENENT = 70, LENENV = 50,
480 & LENENA = LENENP + LENENT + LENENV )
481 INTEGER TOTE, TOTKE, EPOT, TEMPS, GRMS, BPRESS, PJNK1, PJNK2,
482 & PJNK3, PJNK4, HFCTE, HFCKE, EHFC, EWORK, VOLUME, PRESSE,
483 & PRESSI, VIRI, VIRE, VIRKE, TEPR, PEPR, KEPR, KEPR2,
484 & DROFFA,
485 & XTLTE, XTLKE, XTLPE, XTLTEM, XTLPEP, XTLKEP, XTLKP2,
486 & TOT4, TOTK4, EPOT4, TEM4, MbMom, BodyT, PartT
487 C..##IF ACE
488 & , SELF, SCREEN, COUL ,SOLV, INTER
489 C..##ENDIF
490 C..##IF FLUCQ
491 & ,FQKIN
492 C..##ENDIF
493 PARAMETER (TOTE = 1, TOTKE = 2, EPOT = 3, TEMPS = 4,
494 & GRMS = 5, BPRESS = 6, PJNK1 = 7, PJNK2 = 8,
495 & PJNK3 = 9, PJNK4 = 10, HFCTE = 11, HFCKE = 12,
496 & EHFC = 13, EWORK = 11, VOLUME = 15, PRESSE = 16,
497 & PRESSI = 17, VIRI = 18, VIRE = 19, VIRKE = 20,
498 & TEPR = 21, PEPR = 22, KEPR = 23, KEPR2 = 24,
499 & DROFFA = 26, XTLTE = 27, XTLKE = 28,
500 & XTLPE = 29, XTLTEM = 30, XTLPEP = 31, XTLKEP = 32,
501 & XTLKP2 = 33,
502 & TOT4 = 37, TOTK4 = 38, EPOT4 = 39, TEM4 = 40,
503 & MbMom = 41, BodyT = 42, PartT = 43
504 C..##IF ACE
505 & , SELF = 45, SCREEN = 46, COUL = 47,
506 & SOLV = 48, INTER = 49
507 C..##ENDIF
508 C..##IF FLUCQ
509 & ,FQKIN = 50
510 C..##ENDIF
511 & )
512 C..##IF ACE
513 C..##ENDIF
514 C..##IF GRID
515 C..##ENDIF
516 C..##IF FLUCQ
517 C..##ENDIF
518 INTEGER BOND, ANGLE, UREYB, DIHE, IMDIHE, VDW, ELEC, HBOND,
519 & USER, CHARM, CDIHE, CINTCR, CQRT, NOE, SBNDRY,
520 & IMVDW, IMELEC, IMHBND, EWKSUM, EWSELF, EXTNDE, RXNFLD,
521 & ST2, IMST2, TSM, QMEL, QMVDW, ASP, EHARM, GEO, MDIP,
522 & PRMS, PANG, SSBP, BK4D, SHEL, RESD, SHAP,
523 & STRB, OOPL, PULL, POLAR, DMC, RGY, EWEXCL, EWQCOR,
524 & EWUTIL, PBELEC, PBNP, PINT, MbDefrm, MbElec, STRSTR,
525 & BNDBND, BNDTW, EBST, MBST, BBT, SST, GBEnr, GSBP
526 C..##IF HMCM
527 & , HMCM
528 C..##ENDIF
529 C..##IF ADUMB
530 & , ADUMB
531 C..##ENDIF
532 & , HYDR
533 C..##IF FLUCQ
534 & , FQPOL
535 C..##ENDIF
536 PARAMETER (BOND = 1, ANGLE = 2, UREYB = 3, DIHE = 4,
537 & IMDIHE = 5, VDW = 6, ELEC = 7, HBOND = 8,
538 & USER = 9, CHARM = 10, CDIHE = 11, CINTCR = 12,
539 & CQRT = 13, NOE = 14, SBNDRY = 15, IMVDW = 16,
540 & IMELEC = 17, IMHBND = 18, EWKSUM = 19, EWSELF = 20,
541 & EXTNDE = 21, RXNFLD = 22, ST2 = 23, IMST2 = 24,
542 & TSM = 25, QMEL = 26, QMVDW = 27, ASP = 28,
543 & EHARM = 29, GEO = 30, MDIP = 31, PINT = 32,
544 & PRMS = 33, PANG = 34, SSBP = 35, BK4D = 36,
545 & SHEL = 37, RESD = 38, SHAP = 39, STRB = 40,
546 & OOPL = 41, PULL = 42, POLAR = 43, DMC = 44,
547 & RGY = 45, EWEXCL = 46, EWQCOR = 47, EWUTIL = 48,
548 & PBELEC = 49, PBNP = 50, MbDefrm= 51, MbElec = 52,
549 & STRSTR = 53, BNDBND = 54, BNDTW = 55, EBST = 56,
550 & MBST = 57, BBT = 58, SST = 59, GBEnr = 60,
551 & GSBP = 65
552 C..##IF HMCM
553 & , HMCM = 61
554 C..##ENDIF
555 C..##IF ADUMB
556 & , ADUMB = 62
557 C..##ENDIF
558 & , HYDR = 63
559 C..##IF FLUCQ
560 & , FQPOL = 65
561 C..##ENDIF
562 & )
563 INTEGER VEXX, VEXY, VEXZ, VEYX, VEYY, VEYZ, VEZX, VEZY, VEZZ,
564 & VIXX, VIXY, VIXZ, VIYX, VIYY, VIYZ, VIZX, VIZY, VIZZ,
565 & PEXX, PEXY, PEXZ, PEYX, PEYY, PEYZ, PEZX, PEZY, PEZZ,
566 & PIXX, PIXY, PIXZ, PIYX, PIYY, PIYZ, PIZX, PIZY, PIZZ
567 PARAMETER ( VEXX = 1, VEXY = 2, VEXZ = 3, VEYX = 4,
568 & VEYY = 5, VEYZ = 6, VEZX = 7, VEZY = 8,
569 & VEZZ = 9,
570 & VIXX = 10, VIXY = 11, VIXZ = 12, VIYX = 13,
571 & VIYY = 14, VIYZ = 15, VIZX = 16, VIZY = 17,
572 & VIZZ = 18,
573 & PEXX = 19, PEXY = 20, PEXZ = 21, PEYX = 22,
574 & PEYY = 23, PEYZ = 24, PEZX = 25, PEZY = 26,
575 & PEZZ = 27,
576 & PIXX = 28, PIXY = 29, PIXZ = 30, PIYX = 31,
577 & PIYY = 32, PIYZ = 33, PIZX = 34, PIZY = 35,
578 & PIZZ = 36)
579 CHARACTER(4) CEPROP, CETERM, CEPRSS
580 COMMON /ANER/ CEPROP(LENENP), CETERM(LENENT), CEPRSS(LENENV)
581 LOGICAL QEPROP, QETERM, QEPRSS
582 COMMON /QENER/ QEPROP(LENENP), QETERM(LENENT), QEPRSS(LENENV)
583 REAL(KIND=8) EPROP, ETERM, EPRESS
584 COMMON /ENER/ EPROP(LENENP), ETERM(LENENT), EPRESS(LENENV)
585 C..##IF SAVEFCM
586 C..##ENDIF
587 REAL(KIND=8) EPRPA, EPRP2A, EPRPP, EPRP2P,
588 & ETRMA, ETRM2A, ETRMP, ETRM2P,
589 & EPRSA, EPRS2A, EPRSP, EPRS2P
590 COMMON /ENACCM/ EPRPA(LENENP), ETRMA(LENENT), EPRSA(LENENV),
591 & EPRP2A(LENENP),ETRM2A(LENENT),EPRS2A(LENENV),
592 & EPRPP(LENENP), ETRMP(LENENT), EPRSP(LENENV),
593 & EPRP2P(LENENP),ETRM2P(LENENT),EPRS2P(LENENV)
594 C..##IF SAVEFCM
595 C..##ENDIF
596 INTEGER ECALLS, TOT1ST, TOT2ND
597 COMMON /EMISCI/ ECALLS, TOT1ST, TOT2ND
598 REAL(KIND=8) EOLD, FITA, DRIFTA, EAT0A, CORRA, FITP, DRIFTP,
599 & EAT0P, CORRP
600 COMMON /EMISCR/ EOLD, FITA, DRIFTA, EAT0A, CORRA,
601 & FITP, DRIFTP, EAT0P, CORRP
602 C..##IF SAVEFCM
603 C..##ENDIF
604 C..##IF ACE
605 C..##ENDIF
606 C..##IF FLUCQ
607 C..##ENDIF
608 C..##IF ADUMB
609 C..##ENDIF
610 C..##IF GRID
611 C..##ENDIF
612 C..##IF FLUCQ
613 C..##ENDIF
614 C..##IF TSM
615 REAL(KIND=8) TSMTRM(LENENT),TSMTMP(LENENT)
616 COMMON /TSMENG/ TSMTRM,TSMTMP
617 C...##IF SAVEFCM
618 C...##ENDIF
619 C..##ENDIF
620 REAL(KIND=8) EHQBM
621 LOGICAL HQBM
622 COMMON /HQBMVAR/HQBM
623 C..##IF SAVEFCM
624 C..##ENDIF
625 C-----------------------------------------------------------------------
626 C-----------------------------------------------------------------------
627 C:::##INCLUDE '~/charmm_fcm/dimb.fcm'
628 C..##IF DIMB (dimbfcm)
629 INTEGER NPARMX,MNBCMP,LENDSK
630 PARAMETER (NPARMX=1000,MNBCMP=300,LENDSK=200000)
631 INTEGER IJXXCM,IJXYCM,IJXZCM,IJYXCM,IJYYCM
632 INTEGER IJYZCM,IJZXCM,IJZYCM,IJZZCM
633 INTEGER IIXXCM,IIXYCM,IIXZCM,IIYYCM
634 INTEGER IIYZCM,IIZZCM
635 INTEGER JJXXCM,JJXYCM,JJXZCM,JJYYCM
636 INTEGER JJYZCM,JJZZCM
637 PARAMETER (IJXXCM=1,IJXYCM=2,IJXZCM=3,IJYXCM=4,IJYYCM=5)
638 PARAMETER (IJYZCM=6,IJZXCM=7,IJZYCM=8,IJZZCM=9)
639 PARAMETER (IIXXCM=1,IIXYCM=2,IIXZCM=3,IIYYCM=4)
640 PARAMETER (IIYZCM=5,IIZZCM=6)
641 PARAMETER (JJXXCM=1,JJXYCM=2,JJXZCM=3,JJYYCM=4)
642 PARAMETER (JJYZCM=5,JJZZCM=6)
643 INTEGER ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,PDD1CM,LENCMP
644 LOGICAL QDISK,QDW,QCMPCT
645 COMMON /DIMBI/ ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,LENCMP
646 COMMON /DIMBL/ QDISK,QDW,QCMPCT
647 C...##IF SAVEFCM
648 C...##ENDIF
649 C..##ENDIF (dimbfcm)
650 C-----------------------------------------------------------------------
651 C-----------------------------------------------------------------------
652 C:::##INCLUDE '~/charmm_fcm/ctitla.fcm'
653 INTEGER MAXTIT
654 PARAMETER (MAXTIT=32)
655 INTEGER NTITLA,NTITLB
656 CHARACTER(80) TITLEA,TITLEB
657 COMMON /NTITLA/ NTITLA,NTITLB
658 COMMON /CTITLA/ TITLEA(MAXTIT),TITLEB(MAXTIT)
659 C..##IF SAVEFCM
660 C..##ENDIF
661 C-----------------------------------------------------------------------
662 C Passed variables
663 INTEGER NAT3,NADD,NPAR,NFREG,NFRET,BLATOM
664 INTEGER ATMPAR(2,*),ATMPAS(2,*),ATMPAD(2,*)
665 INTEGER BNBND(*),BIMAG(*)
666 INTEGER INBCMP(*),JNBCMP(*),PARDIM
667 INTEGER ITMX,IUNMOD,IUNRMD,SAVF
668 INTEGER NBOND,IB(*),JB(*)
669 REAL(KIND=8) X(*),Y(*),Z(*),AMASS(*),DDSCR(*)
670 REAL(KIND=8) DDV(NAT3,*),PARDDV(PARDIM,*),DDM(*),DDS(*)
671 REAL(KIND=8) DDF(*),PARDDF(*),DDEV(*),PARDDE(*)
672 REAL(KIND=8) DD1BLK(*),DD1BLL(*),DD1CMP(*)
673 REAL(KIND=8) TOLDIM,DDVALM
674 REAL(KIND=8) PARFRQ,CUTF1
675 LOGICAL LNOMA,LRAISE,LSCI,LBIG
676 C Local variables
677 INTEGER NATOM,NATP,NDIM,I,J,II,OLDFAS,OLDPRN,IUPD
678 INTEGER NPARC,NPARD,NPARS,NFCUT1,NFREG2,NFREG6
679 INTEGER IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8
680 INTEGER IS1,IS2,IS3,IS4,JSPACE,JSP,DDSS,DD5
681 INTEGER ISTRT,ISTOP,IPA1,IPA2,IRESF
682 INTEGER ATMPAF,INIDS,TRAROT
683 INTEGER SUBLIS,ATMCOR
684 INTEGER NFRRES,DDVBAS
685 INTEGER DDV2,DDVAL
686 INTEGER LENCM,NTR,NFRE,NFC,N1,N2,NFCUT,NSUBP
687 INTEGER SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6
688 INTEGER DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ
689 INTEGER I620,I640,I660,I700,I720,I760,I800,I840,I880,I920
690 REAL(KIND=8) CVGMX,TOLER
691 LOGICAL LCARD,LAPPE,LPURG,LWDINI,QCALC,QMASWT,QMIX,QDIAG
692 C Begin
693 QCALC=.TRUE.
694 LWDINI=.FALSE.
695 INIDS=0
696 IS3=0
697 IS4=0
698 LPURG=.TRUE.
699 ITER=0
700 NADD=0
701 NFSAV=0
702 TOLER=TENM5
703 QDIAG=.TRUE.
704 CVGMX=HUNDRD
705 QMIX=.FALSE.
706 NATOM=NAT3/3
707 NFREG6=(NFREG-6)/NPAR
708 NFREG2=NFREG/2
709 NFRRES=(NFREG+6)/2
710 IF(NFREG.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>',
711 1 'NFREG IS LARGER THAN PARDIM*3')
712 C
713 C ALLOCATE-SPACE-FOR-TRANSROT-VECTORS
714 ASSIGN 801 TO I800 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
715 GOTO 800
716 801 CONTINUE
717 C ALLOCATE-SPACE-FOR-DIAGONALIZATION
718 ASSIGN 721 TO I720 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
719 GOTO 720
720 721 CONTINUE
721 C ALLOCATE-SPACE-FOR-REDUCED-BASIS
722 ASSIGN 761 TO I760 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
723 GOTO 760
724 761 CONTINUE
725 C ALLOCATE-SPACE-FOR-OTHER-ARRAYS
726 ASSIGN 921 TO I920 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
727 GOTO 920
728 921 CONTINUE
729 C
730 C Space allocation for working arrays of EISPACK
731 C diagonalization subroutines
732 IF(LSCI) THEN
733 C ALLOCATE-SPACE-FOR-LSCI
734 ASSIGN 841 TO I840 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
735 GOTO 840
736 841 CONTINUE
737 ELSE
738 C ALLOCATE-DUMMY-SPACE-FOR-LSCI
739 ASSIGN 881 TO I880 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
740 GOTO 880
741 881 CONTINUE
742 ENDIF
743 QMASWT=(.NOT.LNOMA)
744 IF(.NOT. QDISK) THEN
745 LENCM=INBCMP(NATOM-1)*9+NATOM*6
746 DO I=1,LENCM
747 DD1CMP(I)=0.0
748 ENDDO
749 OLDFAS=LFAST
750 QCMPCT=.TRUE.
751 LFAST = -1
752 CALL ENERGY(X,Y,Z,DX,DY,DZ,BNBND,BIMAG,NAT3,DD1CMP,.TRUE.,1)
753 LFAST=OLDFAS
754 QCMPCT=.FALSE.
755 C
756 C Mass weight DD1CMP matrix
757 C
758 CALL MASSDD(DD1CMP,DDM,INBCMP,JNBCMP,NATOM)
759 ELSE
760 CALL WRNDIE(-3,'<NMDIMB>','QDISK OPTION NOT SUPPORTED YET')
761 C DO I=1,LENDSK
762 C DD1CMP(I)=0.0
763 C ENDDO
764 C OLDFAS=LFAST
765 C LFAST = -1
766 ENDIF
767 C
768 C Fill DDV with six translation-rotation vectors
769 C
770 CALL TRROT(X,Y,Z,DDV,NAT3,1,DDM)
771 CALL CPARAY(HEAP(TRAROT),DDV,NAT3,1,6,1)
772 NTR=6
773 OLDPRN=PRNLEV
774 PRNLEV=1
775 CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER)
776 PRNLEV=OLDPRN
777 IF(IUNRMD .LT. 0) THEN
778 C
779 C If no previous basis is read
780 C
781 IF(PRNLEV.GE.2) WRITE(OUTU,502) NPAR
782 502 FORMAT(/' NMDIMB: Calculating initial basis from block ',
783 1 'diagonals'/' NMDIMB: The number of blocks is ',I5/)
784 NFRET = 6
785 DO I=1,NPAR
786 IS1=ATMPAR(1,I)
787 IS2=ATMPAR(2,I)
788 NDIM=(IS2-IS1+1)*3
789 NFRE=NDIM
790 IF(NFRE.GT.NFREG6) NFRE=NFREG6
791 IF(NFREG6.EQ.0) NFRE=1
792 CALL FILUPT(HEAP(IUPD),NDIM)
793 CALL MAKDDU(DD1BLK,DD1CMP,INBCMP,JNBCMP,HEAP(IUPD),
794 1 IS1,IS2,NATOM)
795 IF(PRNLEV.GE.9) CALL PRINTE(OUTU,EPROP,ETERM,'VIBR',
796 1 'ENR',.TRUE.,1,ZERO,ZERO)
797 C
798 C Generate the lower section of the matrix and diagonalize
799 C
800 C..##IF EISPACK
801 C..##ENDIF
802 IH1=1
803 NATP=NDIM+1
804 IH2=IH1+NATP
805 IH3=IH2+NATP
806 IH4=IH3+NATP
807 IH5=IH4+NATP
808 IH6=IH5+NATP
809 IH7=IH6+NATP
810 IH8=IH7+NATP
811 CALL DIAGQ(NDIM,NFRE,DD1BLK,PARDDV,DDS(IH2),DDS(IH3),
812 1 DDS(IH4),DDS(IH5),DDS,DDS(IH6),DDS(IH7),DDS(IH8),NADD)
813 C..##IF EISPACK
814 C..##ENDIF
815 C
816 C Put the PARDDV vectors into DDV and replace the elements which do
817 C not belong to the considered partitioned region by zeros.
818 C
819 CALL ADJNME(DDV,PARDDV,NAT3,NDIM,NFRE,NFRET,IS1,IS2)
820 IF(LSCI) THEN
821 DO J=1,NFRE
822 PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J)))
823 IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J)
824 ENDDO
825 ELSE
826 DO J=1,NFRE
827 PARDDE(J)=DDS(J)
828 PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J)))
829 IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J)
830 ENDDO
831 ENDIF
832 IF(PRNLEV.GE.2) THEN
833 WRITE(OUTU,512) I
834 WRITE(OUTU,514)
835 WRITE(OUTU,516) (J,PARDDF(J),J=1,NFRE)
836 ENDIF
837 NFRET=NFRET+NFRE
838 IF(NFRET .GE. NFREG) GOTO 10
839 ENDDO
840 512 FORMAT(/' NMDIMB: Diagonalization of part',I5,' completed')
841 514 FORMAT(' NMDIMB: Frequencies'/)
842 516 FORMAT(5(I4,F12.6))
843 10 CONTINUE
844 C
845 C Orthonormalize the eigenvectors
846 C
847 OLDPRN=PRNLEV
848 PRNLEV=1
849 CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER)
850 PRNLEV=OLDPRN
851 C
852 C Do reduced basis diagonalization using the DDV vectors
853 C and get eigenvectors of zero iteration
854 C
855 IF(PRNLEV.GE.2) THEN
856 WRITE(OUTU,521) ITER
857 WRITE(OUTU,523) NFRET
858 ENDIF
859 521 FORMAT(/' NMDIMB: Iteration number = ',I5)
860 523 FORMAT(' NMDIMB: Dimension of the reduced basis set = ',I5)
861 IF(LBIG) THEN
862 IF(PRNLEV.GE.2) WRITE(OUTU,585) NFRET,IUNMOD
863 525 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5)
864 REWIND (UNIT=IUNMOD)
865 LCARD=.FALSE.
866 CALL WRTNMD(LCARD,1,NFRET,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS)
867 CALL SAVEIT(IUNMOD)
868 ELSE
869 CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFRET,1)
870 ENDIF
871 CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
872 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
873 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4,
874 3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
875 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
876 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
877 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
878 C
879 C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
880 C
881 ASSIGN 621 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
882 GOTO 620
883 621 CONTINUE
884 C SAVE-MODES
885 ASSIGN 701 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
886 GOTO 700
887 701 CONTINUE
888 IF(ITER.EQ.ITMX) THEN
889 CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS,
890 1 DDVAL,JSPACE,TRAROT,
891 2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6,
892 3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF,
893 4 ATMCOR,SUBLIS,LSCI,QDW,LBIG)
894 RETURN
895 ENDIF
896 ELSE
897 C
898 C Read in existing basis
899 C
900 IF(PRNLEV.GE.2) THEN
901 WRITE(OUTU,531)
902 531 FORMAT(/' NMDIMB: Calculations restarted')
903 ENDIF
904 C READ-MODES
905 ISTRT=1
906 ISTOP=99999999
907 LCARD=.FALSE.
908 LAPPE=.FALSE.
909 CALL RDNMD(LCARD,NFRET,NFREG,NAT3,NDIM,
910 1 DDV,DDSCR,DDF,DDEV,
911 2 IUNRMD,LAPPE,ISTRT,ISTOP)
912 NFRET=NDIM
913 IF(NFRET.GT.NFREG) THEN
914 NFRET=NFREG
915 CALL WRNDIE(-1,'<NMDIMB>',
916 1 'Not enough space to hold the basis. Increase NMODes')
917 ENDIF
918 C PRINT-MODES
919 IF(PRNLEV.GE.2) THEN
920 WRITE(OUTU,533) NFRET,IUNRMD
921 WRITE(OUTU,514)
922 WRITE(OUTU,516) (J,DDF(J),J=1,NFRET)
923 ENDIF
924 533 FORMAT(/' NMDIMB: ',I5,' restart modes read from unit ',I5)
925 NFRRES=NFRET
926 ENDIF
927 C
928 C -------------------------------------------------
929 C Here starts the mixed-basis diagonalization part.
930 C -------------------------------------------------
931 C
932 C
933 C Check cut-off frequency
934 C
935 CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1)
936 C TEST-NFCUT1
937 IF(IUNRMD.LT.0) THEN
938 IF(NFCUT1*2-6.GT.NFREG) THEN
939 IF(PRNLEV.GE.2) WRITE(OUTU,537) DDF(NFRRES)
940 NFCUT1=NFRRES
941 CUTF1=DDF(NFRRES)
942 ENDIF
943 ELSE
944 CUTF1=DDF(NFRRES)
945 ENDIF
946 537 FORMAT(/' NMDIMB: Too many vectors for the given cutoff frequency'
947 1 /' Cutoff frequency is decreased to',F9.3)
948 C
949 C Compute the new partioning of the molecule
950 C
951 CALL PARTIC(NAT3,NFREG,NFCUT1,NPARMX,NPARC,ATMPAR,NFRRES,
952 1 PARDIM)
953 NPARS=NPARC
954 DO I=1,NPARC
955 ATMPAS(1,I)=ATMPAR(1,I)
956 ATMPAS(2,I)=ATMPAR(2,I)
957 ENDDO
958 IF(QDW) THEN
959 IF(IPAR1.EQ.0.OR.IPAR2.EQ.0) LWDINI=.TRUE.
960 IF(IPAR1.GE.IPAR2) LWDINI=.TRUE.
961 IF(IABS(IPAR1).GT.NPARC*2) LWDINI=.TRUE.
962 IF(IABS(IPAR2).GT.NPARC*2) LWDINI=.TRUE.
963 IF(ITER.EQ.0) LWDINI=.TRUE.
964 ENDIF
965 ITMX=ITMX+ITER
966 IF(PRNLEV.GE.2) THEN
967 WRITE(OUTU,543) ITER,ITMX
968 IF(QDW) WRITE(OUTU,545) IPAR1,IPAR2
969 ENDIF
970 543 FORMAT(/' NMDIMB: Previous iteration number = ',I8/
971 1 ' NMDIMB: Iteration number to reach = ',I8)
972 545 FORMAT(' NMDIMB: Previous sub-blocks = ',I5,2X,I5)
973 C
974 IF(SAVF.LE.0) SAVF=NPARC
975 IF(PRNLEV.GE.2) WRITE(OUTU,547) SAVF
976 547 FORMAT(' NMDIMB: Eigenvectors will be saved every',I5,
977 1 ' iterations')
978 C
979 C If double windowing is defined, the original block sizes are divided
980 C in two.
981 C
982 IF(QDW) THEN
983 NSUBP=1
984 CALL PARTID(NPARC,ATMPAR,NPARD,ATMPAD,NPARMX)
985 ATMPAF=ALLHP(INTEG4(NPARD*NPARD))
986 ATMCOR=ALLHP(INTEG4(NATOM))
987 DDVAL=ALLHP(IREAL8(NPARD*NPARD))
988 CALL CORARR(ATMPAD,NPARD,HEAP(ATMCOR),NATOM)
989 CALL PARLIS(HEAP(ATMCOR),HEAP(ATMPAF),INBCMP,JNBCMP,NPARD,
990 2 NSUBP,NATOM,X,Y,Z,NBOND,IB,JB,DD1CMP,HEAP(DDVAL),DDVALM)
991 SUBLIS=ALLHP(INTEG4(NSUBP*2))
992 CALL PARINT(HEAP(ATMPAF),NPARD,HEAP(SUBLIS),NSUBP)
993 CALL INIPAF(HEAP(ATMPAF),NPARD)
994 C
995 C Find out with which block to continue (double window method only)
996 C
997 IPA1=IPAR1
998 IPA2=IPAR2
999 IRESF=0
1000 IF(LWDINI) THEN
1001 ITER=0
1002 LWDINI=.FALSE.
1003 GOTO 500
1004 ENDIF
1005 DO II=1,NSUBP
1006 CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF),
1007 1 NPARD,QCALC)
1008 IF((IPAR1.EQ.IPA1).AND.(IPAR2.EQ.IPA2)) GOTO 500
1009 ENDDO
1010 ENDIF
1011 500 CONTINUE
1012 C
1013 C Main loop.
1014 C
1015 DO WHILE((CVGMX.GT.TOLDIM).AND.(ITER.LT.ITMX))
1016 IF(.NOT.QDW) THEN
1017 ITER=ITER+1
1018 IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER
1019 553 FORMAT(/' NMDIMB: Iteration number = ',I8)
1020 IF(INIDS.EQ.0) THEN
1021 INIDS=1
1022 ELSE
1023 INIDS=0
1024 ENDIF
1025 CALL PARTDS(NAT3,NPARC,ATMPAR,NPARS,ATMPAS,INIDS,NPARMX,
1026 1 DDF,NFREG,CUTF1,PARDIM,NFCUT1)
1027 C DO-THE-DIAGONALISATIONS
1028 ASSIGN 641 to I640 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
1029 GOTO 640
1030 641 CONTINUE
1031 QDIAG=.FALSE.
1032 C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
1033 ASSIGN 622 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
1034 GOTO 620
1035 622 CONTINUE
1036 QDIAG=.TRUE.
1037 C SAVE-MODES
1038 ASSIGN 702 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
1039 GOTO 700
1040 702 CONTINUE
1041 C
1042 ELSE
1043 DO II=1,NSUBP
1044 CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF),
1045 1 NPARD,QCALC)
1046 IF(QCALC) THEN
1047 IRESF=IRESF+1
1048 ITER=ITER+1
1049 IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER
1050 C DO-THE-DWIN-DIAGONALISATIONS
1051 ASSIGN 661 TO I660 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
1052 GOTO 660
1053 661 CONTINUE
1054 ENDIF
1055 IF((IRESF.EQ.SAVF).OR.(ITER.EQ.ITMX)) THEN
1056 IRESF=0
1057 QDIAG=.FALSE.
1058 C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
1059 ASSIGN 623 TO I620 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
1060 GOTO 620
1061 623 CONTINUE
1062 QDIAG=.TRUE.
1063 IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600
1064 C SAVE-MODES
1065 ASSIGN 703 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
1066 GOTO 700
1067 703 CONTINUE
1068 ENDIF
1069 ENDDO
1070 ENDIF
1071 ENDDO
1072 600 CONTINUE
1073 C
1074 C SAVE-MODES
1075 ASSIGN 704 TO I700 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" }
1076 GOTO 700
1077 704 CONTINUE
1078 CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS,
1079 1 DDVAL,JSPACE,TRAROT,
1080 2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6,
1081 3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF,
1082 4 ATMCOR,SUBLIS,LSCI,QDW,LBIG)
1083 RETURN
1084 C-----------------------------------------------------------------------
1085 C INTERNAL PROCEDURES
1086 C-----------------------------------------------------------------------
1087 C TO DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
1088 620 CONTINUE
1089 IF(IUNRMD.LT.0) THEN
1090 CALL SELNMD(DDF,NFRET,CUTF1,NFC)
1091 N1=NFCUT1
1092 N2=(NFRET+6)/2
1093 NFCUT=MAX(N1,N2)
1094 IF(NFCUT*2-6 .GT. NFREG) THEN
1095 NFCUT=(NFREG+6)/2
1096 CUTF1=DDF(NFCUT)
1097 IF(PRNLEV.GE.2) THEN
1098 WRITE(OUTU,562) ITER
1099 WRITE(OUTU,564) CUTF1
1100 ENDIF
1101 ENDIF
1102 ELSE
1103 NFCUT=NFRET
1104 NFC=NFRET
1105 ENDIF
1106 562 FORMAT(/' NMDIMB: Not enough space to hold the residual vectors'/
1107 1 ' into DDV array during iteration ',I5)
1108 564 FORMAT(' Cutoff frequency is changed to ',F9.3)
1109 C
1110 C do reduced diagonalization with preceding eigenvectors plus
1111 C residual vectors
1112 C
1113 ISTRT=1
1114 ISTOP=NFCUT
1115 CALL CLETR(DDV,HEAP(TRAROT),NAT3,ISTRT,ISTOP,NFCUT,DDEV,DDF)
1116 CALL RNMTST(DDV,HEAP(DDVBAS),NAT3,DDSCR,DD1CMP,INBCMP,JNBCMP,
1117 2 7,NFCUT,CVGMX,NFCUT,NFC,QDIAG,LBIG,IUNMOD)
1118 NFSAV=NFCUT
1119 IF(QDIAG) THEN
1120 NFRET=NFCUT*2-6
1121 IF(PRNLEV.GE.2) WRITE(OUTU,566) NFRET
1122 566 FORMAT(/' NMDIMB: Diagonalization with residual vectors. '/
1123 1 ' Dimension of the reduced basis set'/
1124 2 ' before orthonormalization = ',I5)
1125 NFCUT=NFRET
1126 OLDPRN=PRNLEV
1127 PRNLEV=1
1128 CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER)
1129 PRNLEV=OLDPRN
1130 NFRET=NFCUT
1131 IF(PRNLEV.GE.2) WRITE(OUTU,568) NFRET
1132 568 FORMAT(' after orthonormalization = ',I5)
1133 IF(LBIG) THEN
1134 IF(PRNLEV.GE.2) WRITE(OUTU,570) NFCUT,IUNMOD
1135 570 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5)
1136 REWIND (UNIT=IUNMOD)
1137 LCARD=.FALSE.
1138 CALL WRTNMD(LCARD,1,NFCUT,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS)
1139 CALL SAVEIT(IUNMOD)
1140 ELSE
1141 CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
1142 ENDIF
1143 QMIX=.FALSE.
1144 CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1145 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
1146 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4,
1147 3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
1148 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
1149 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
1150 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
1151 CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1)
1152 ENDIF
1153 GOTO I620 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1154 C
1155 C-----------------------------------------------------------------------
1156 C TO DO-THE-DIAGONALISATIONS
1157 640 CONTINUE
1158 DO I=1,NPARC
1159 NFCUT1=NFRRES
1160 IS1=ATMPAR(1,I)
1161 IS2=ATMPAR(2,I)
1162 NDIM=(IS2-IS1+1)*3
1163 IF(PRNLEV.GE.2) WRITE(OUTU,573) I,IS1,IS2
1164 573 FORMAT(/' NMDIMB: Mixed diagonalization, part ',I5/
1165 1 ' NMDIMB: Block limits: ',I5,2X,I5)
1166 IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>',
1167 1 'Error in dimension of block')
1168 NFRET=NFCUT1
1169 IF(NFRET.GT.NFREG) NFRET=NFREG
1170 CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF)
1171 NFCUT1=NFCUT
1172 CALL ADZER(DDV,1,NFCUT1,NAT3,IS1,IS2)
1173 NFSAV=NFCUT1
1174 OLDPRN=PRNLEV
1175 PRNLEV=1
1176 CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER)
1177 PRNLEV=OLDPRN
1178 CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
1179 NFRET=NDIM+NFCUT
1180 QMIX=.TRUE.
1181 CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1182 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
1183 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4,
1184 3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
1185 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
1186 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
1187 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
1188 QMIX=.FALSE.
1189 IF(NFCUT.GT.NFRRES) NFCUT=NFRRES
1190 NFCUT1=NFCUT
1191 NFRET=NFCUT
1192 ENDDO
1193 GOTO I640 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1194 C
1195 C-----------------------------------------------------------------------
1196 C TO DO-THE-DWIN-DIAGONALISATIONS
1197 660 CONTINUE
1198 C
1199 C Store the DDV vectors into DDVBAS
1200 C
1201 NFCUT1=NFRRES
1202 IS1=ATMPAD(1,IPAR1)
1203 IS2=ATMPAD(2,IPAR1)
1204 IS3=ATMPAD(1,IPAR2)
1205 IS4=ATMPAD(2,IPAR2)
1206 NDIM=(IS2-IS1+IS4-IS3+2)*3
1207 IF(PRNLEV.GE.2) WRITE(OUTU,577) IPAR1,IPAR2,IS1,IS2,IS3,IS4
1208 577 FORMAT(/' NMDIMB: Mixed double window diagonalization, parts ',
1209 1 2I5/
1210 2 ' NMDIMB: Block limits: ',I5,2X,I5,4X,I5,2X,I5)
1211 IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>',
1212 1 'Error in dimension of block')
1213 NFRET=NFCUT1
1214 IF(NFRET.GT.NFREG) NFRET=NFREG
1215 C
1216 C Prepare the DDV vectors consisting of 6 translations-rotations
1217 C + eigenvectors from 7 to NFCUT1 + cartesian displacements vectors
1218 C spanning the atoms from IS1 to IS2
1219 C
1220 CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF)
1221 NFCUT1=NFCUT
1222 NFSAV=NFCUT1
1223 CALL ADZERD(DDV,1,NFCUT1,NAT3,IS1,IS2,IS3,IS4)
1224 OLDPRN=PRNLEV
1225 PRNLEV=1
1226 CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER)
1227 PRNLEV=OLDPRN
1228 CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1)
1229 C
1230 NFRET=NDIM+NFCUT
1231 QMIX=.TRUE.
1232 CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV,
1233 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD,
1234 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4,
1235 3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1),
1236 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6),
1237 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ),
1238 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD)
1239 QMIX=.FALSE.
1240 C
1241 IF(NFCUT.GT.NFRRES) NFCUT=NFRRES
1242 NFCUT1=NFCUT
1243 NFRET=NFCUT
1244 GOTO I660 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1245 C
1246 C-----------------------------------------------------------------------
1247 C TO SAVE-MODES
1248 700 CONTINUE
1249 IF(PRNLEV.GE.2) WRITE(OUTU,583) IUNMOD
1250 583 FORMAT(/' NMDIMB: Saving the eigenvalues and eigenvectors to unit'
1251 1 ,I4)
1252 REWIND (UNIT=IUNMOD)
1253 ISTRT=1
1254 ISTOP=NFSAV
1255 LCARD=.FALSE.
1256 IF(PRNLEV.GE.2) WRITE(OUTU,585) NFSAV,IUNMOD
1257 585 FORMAT(' NMDIMB: ',I5,' modes are saved in unit',I5)
1258 CALL WRTNMD(LCARD,ISTRT,ISTOP,NAT3,DDV,DDSCR,DDEV,IUNMOD,
1259 1 AMASS)
1260 CALL SAVEIT(IUNMOD)
1261 GOTO I700 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1262 C
1263 C-----------------------------------------------------------------------
1264 C TO ALLOCATE-SPACE-FOR-DIAGONALIZATION
1265 720 CONTINUE
1266 DDV2=ALLHP(IREAL8((PARDIM+3)*(PARDIM+3)))
1267 JSPACE=IREAL8((PARDIM+4))*8
1268 JSP=IREAL8(((PARDIM+3)*(PARDIM+4))/2)
1269 JSPACE=JSPACE+JSP
1270 DDSS=ALLHP(JSPACE)
1271 DD5=DDSS+JSPACE-JSP
1272 GOTO I720 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1273 C
1274 C-----------------------------------------------------------------------
1275 C TO ALLOCATE-SPACE-FOR-REDUCED-BASIS
1276 760 CONTINUE
1277 IF(LBIG) THEN
1278 DDVBAS=ALLHP(IREAL8(NAT3))
1279 ELSE
1280 DDVBAS=ALLHP(IREAL8(NFREG*NAT3))
1281 ENDIF
1282 GOTO I760 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1283 C
1284 C-----------------------------------------------------------------------
1285 C TO ALLOCATE-SPACE-FOR-TRANSROT-VECTORS
1286 800 CONTINUE
1287 TRAROT=ALLHP(IREAL8(6*NAT3))
1288 GOTO I800 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1289 C
1290 C-----------------------------------------------------------------------
1291 C TO ALLOCATE-SPACE-FOR-LSCI
1292 840 CONTINUE
1293 SCIFV1=ALLHP(IREAL8(PARDIM+3))
1294 SCIFV2=ALLHP(IREAL8(PARDIM+3))
1295 SCIFV3=ALLHP(IREAL8(PARDIM+3))
1296 SCIFV4=ALLHP(IREAL8(PARDIM+3))
1297 SCIFV6=ALLHP(IREAL8(PARDIM+3))
1298 DRATQ=ALLHP(IREAL8(PARDIM+3))
1299 ERATQ=ALLHP(IREAL8(PARDIM+3))
1300 E2RATQ=ALLHP(IREAL8(PARDIM+3))
1301 BDRATQ=ALLHP(IREAL8(PARDIM+3))
1302 INRATQ=ALLHP(INTEG4(PARDIM+3))
1303 GOTO I840 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1304 C
1305 C-----------------------------------------------------------------------
1306 C TO ALLOCATE-DUMMY-SPACE-FOR-LSCI
1307 880 CONTINUE
1308 SCIFV1=ALLHP(IREAL8(2))
1309 SCIFV2=ALLHP(IREAL8(2))
1310 SCIFV3=ALLHP(IREAL8(2))
1311 SCIFV4=ALLHP(IREAL8(2))
1312 SCIFV6=ALLHP(IREAL8(2))
1313 DRATQ=ALLHP(IREAL8(2))
1314 ERATQ=ALLHP(IREAL8(2))
1315 E2RATQ=ALLHP(IREAL8(2))
1316 BDRATQ=ALLHP(IREAL8(2))
1317 INRATQ=ALLHP(INTEG4(2))
1318 GOTO I880 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1319 C
1320 C-----------------------------------------------------------------------
1321 C TO ALLOCATE-SPACE-FOR-OTHER-ARRAYS
1322 920 CONTINUE
1323 IUPD=ALLHP(INTEG4(PARDIM+3))
1324 GOTO I920 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" }
1325 C.##ELSE
1326 C.##ENDIF
1327 END