1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18C 19C FILE: abacus/abander.F 20C 21C /* Deck nmdinp */ 22 SUBROUTINE NMDINP(WORD,IDRPRI) 23#include "implicit.h" 24#include "priunit.h" 25#include "mxcent.h" 26 PARAMETER (NDIR=3,NTABLE = 22) 27 CHARACTER PROMPT*1, WORD*7, GRPTMP*15, TABLE(NTABLE)*7, 28 & TABDIR(NDIR)*7, WORD1*7 29#include "numder.h" 30#include "fcsym.h" 31#include "cbinum.h" 32#include "abainf.h" 33#include "cbiwlk.h" 34#include "cbivib.h" 35 LOGICAL NEWDEF 36C 37 DATA TABDIR/'*PROPAV','*XXXXXX','*VIBANA'/ 38C 39 DATA TABLE /'.DORDR ', '.SYMMET', '.SDRTST', '.RESTRT', '.DRYRUN', 40 * '.XXXXXX', '.NORMAL', '.PRECAL', '.REUSE ', '.XXXXXX', 41 * '.VIBANA', '.TEST N', '.DISPLA', '.PROPER', '.PRINT ', 42 * '.MANUAL', '.HARMON', '.SPECTR', '.MIDAS ', '.THRMID', 43 * '.MINOUT', '.C4FORC'/ 44C 45C *** Initializing variables for *VIBANA and *HARMON. *** 46 CALL NVBINI 47 CALL VIBINI 48C 49C 50C ************************************************ 51C **** Finding the analytical differentiation **** 52C **** order of the energy for the **** 53C **** wavefunction used. **** 54C ************************************************ 55C 56 CALL FNDANA(NAORDR) 57 WRITE (LUPRI,'(/5X,A,I4)') 'Order of analytical ' // 58 & 'energy-derivatives available:', NAORDR 59 WRITE (LUPRI,'(5X,A,I4/)') 'This will be the default.' 60C 61 ICHANG = 0 62 WORD1 = WORD 63 100 CONTINUE 64 READ (LUCMD, '(A7)') WORD 65 CALL UPCASE(WORD) 66 PROMPT = WORD(1:1) 67 IF (PROMPT .EQ. '!' .OR. PROMPT .EQ. '#') THEN 68 GO TO 100 69 ELSE IF (PROMPT .EQ. '.') THEN 70 ICHANG = ICHANG + 1 71 DO 200 I = 1, NTABLE 72 IF (TABLE(I) .EQ. WORD) THEN 73 GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19, 74 * 20,21,22),I 75 END IF 76 200 CONTINUE 77 IF (WORD .EQ. '.OPTION') THEN 78 CALL PRTAB(NTABLE,TABLE,WORD1//' input keywords',LUPRI) 79 GO TO 100 80 END IF 81 WRITE (LUPRI,'(/3A/)') ' Keyword "',WORD, 82 * '" not recognized for '//WORD1 83 CALL PRTAB(NTABLE,TABLE,WORD1//' input keywords',LUPRI) 84 CALL QUIT('Illegal keyword for '//WORD1) 85 1 CONTINUE ! .DORDR 86 READ (LUCMD,*) NMORDR, NAORDR 87 GOTO 100 88 2 CONTINUE ! .SYMMET 89 READ (LUCMD,'(A)') GRPTMP 90 FCLASS(1:3) = ' ' ! If FCLASS are initialized to a longer group name. 91 IJ = 0 92 DO II = 1, 15 93 IF (GRPTMP(II:II).NE.' ') THEN 94 IJ = IJ + 1 95 FCLASS(IJ:IJ) = GRPTMP(II:II) 96 END IF 97 END DO 98 GOTO 100 99 3 CONTINUE ! .SDRTST 100 SDRTST = .TRUE. 101 GOTO 100 102 4 CONTINUE ! .RESTRT 103 RESTRT = .TRUE. 104 GOTO 100 105 5 CONTINUE ! .DRYRUN 106 DRYRUN = .TRUE. 107 READ (LUCMD,*) NMREDU 108 READ (LUCMD,*) (KDRYRN(II),II=1,NMREDU) 109 GOTO 100 110 6 CONTINUE ! .XXXXXX 111 GOTO 100 112 7 CONTINUE ! .NORMAL 113 NRMCRD = .TRUE. 114 GOTO 100 115 8 CONTINUE ! .PRECAL 116 PREHES = .TRUE. 117 GOTO 100 118 9 CONTINUE ! .REUSE 119 REUHES = .TRUE. 120 GOTO 100 121 10 CONTINUE ! .XXXXXX 122 GOTO 100 123 11 CONTINUE ! .VIBANA 124 NUMVIB = .TRUE. 125 GOTO 100 126 12 CONTINUE ! .TEST N 127 NRMCRD = .TRUE. 128 HTEST = .TRUE. 129 GOTO 100 130 13 CONTINUE ! .DISPLA 131 READ (LUCMD, *) DISPLC 132 GOTO 100 133 14 CONTINUE ! .PROPER 134 NPRPDR = .TRUE. 135 READ (LUCMD, *) NMRDRP, NARDRP 136 IF (NMORDR.EQ.0) NAORDR = 0 137 NMORDR = MAX(NMRDRP,NMORDR) 138 GOTO 100 139 15 CONTINUE ! .PRINT 140 READ (LUCMD, *) IDRPRI 141 GOTO 100 142 16 CONTINUE ! .MANUAL 143 MANUAL = .TRUE. 144 GOTO 100 145 17 CONTINUE ! .HARMON 146 HARMON = .TRUE. 147 VIB = .TRUE. 148 MAXDIF = 2 149 GOTO 100 150 18 CONTINUE ! .SPECTR 151 SPECTR = .TRUE. 152 GOTO 100 153 19 CONTINUE ! .MIDAS 154 MIDAS = .TRUE. 155 GOTO 100 156 20 CONTINUE ! .THRMID 157 READ (LUCMD, *) XTHR 158 THRMID = ABS(XTHR) 159 21 CONTINUE ! .MINOUT 160 MINOUT = .TRUE. 161 GOTO 100 162 22 CONTINUE ! .C4FORC 163 C4FORC = .TRUE. 164 GOTO 100 165 ELSE IF (PROMPT .EQ. '*') THEN 166 GO TO 300 167 ELSE 168 WRITE (LUPRI,'(/4A/)') ' Prompt "',WORD, 169 * '" not recognized for ',WORD1 170 CALL PRTAB(NTABLE,TABLE,WORD1//' input keywords',LUPRI) 171 CALL QUIT('Illegal prompt for '//WORD1) 172 END IF 173C 174C *** Print section. *** 175C 176 300 CONTINUE 177 IF (ICHANG .GT. 0) THEN 178 CALL HEADER('Changes of defaults for '//WORD1//':',0) 179 180 IF (NUMVIB) THEN 181 WRITE (LUPRI,'(/5X,A)') 'A vibrational analysis is done.' 182 WRITE (LUPRI,'(5X,A)') 'Which/how is specified in ' // 183 & '*VIBANA (and **EACH STEP).' 184CRF & '*VIBANA (and **PROPERTIES).' 185 ELSE 186 WRITE (LUPRI,'(/5X,A,I4/5X,A,I4,A)') 187 & 'Numerical derivatives calculated to order', NMORDR, 188 & 'using analytical', NAORDR, '. derivatives' 189 END IF 190C 191 WRITE (LUPRI,'(5x,A)') 'Group used for force constants: ' // 192 & FCLASS 193 WRITE (LUPRI,'(5x,A,F10.4)') 'Step size used: ', DISPLC 194 IF (SDRTST) THEN 195 WRITE (LUPRI,'(/5X,A)') 'Comparison of numerical Hessian ' 196 & // 'with analytical Hessian is performed' 197 END IF 198 IF (DRYRUN) THEN 199 WRITE (LUPRI,'(/5X,A)') 'Numerical derivatives will be' // 200 & 'conducted as a dry run.' 201 WRITE (LUPRI,'(5X,A)') 'No actual derivatives will be' // 202 & 'calculated.' 203 WRITE (LUPRI,'(5X,A,I5)') 'Number of redundant coordinates:' 204 & , NMREDU 205 END IF 206C 207 IF (RESTRT) THEN 208 WRITE (LUPRI,'(/5X,A)') 'This is a restart of an old run.' 209 END IF 210C 211 IF (NRMCRD) THEN 212 WRITE (LUPRI,'(/5X,A)') 'Normal coordinates will be found.' 213 WRITE (LUPRI,'(5X,A)') 'Energy and property derivatives' // 214 & 'will be with respect to these coordinates.' 215 END IF 216C 217 IF (PREHES) THEN 218 WRITE (LUPRI,'(/5X,A)') 'A precalculated hessian will be' // 219 & ' used to find normal coordinates.' 220 END IF 221C 222 IF (REUHES) THEN 223 WRITE (LUPRI,'(/5X,A)') 'Hessian (if specified elsewhere)' 224 & // ' will be saved for future work.', 225 & 'Hessian will be saved on the file "DALTON.HES"' 226 END IF 227C 228 IF (NRMCRD.AND.HTEST) THEN 229 WRITE (LUPRI,'(/5X,A)') 'A test of the normal coordinates ' 230 & // 'will be done.' 231 END IF 232C 233 IF (MANUAL) THEN 234 WRITE (LUPRI,'(/5X,A)') 235 & 'The mol file will be printed for geometries.' 236 END IF 237C 238 IF (NPRPDR) THEN 239 WRITE (LUPRI,'(/5X,A)') 240 & 'Property derivatives will be calculated.' 241 IF (NMORDR.GT.0) THEN 242 WRITE (LUPRI,'(5X,A,I4)') 'Order of the' // 243 & 'differentiation is equal to: ', NMORDR 244 END IF 245 END IF 246 IF (MIDAS) THEN 247 WRITE (LUPRI,'(/5X,A)') 248 & 'Operator file for MidasCpp interface '// 249 & 'will be generated.' 250 WRITE (LUPRI,'(5x,A,A,E24.10)') 251 & 'Threshold for term coefficient relative to largest', 252 & ' harmonic term: ',THRMID 253 ENDIF 254 END IF 255C 256C 257C *** Different * sections. *** 258C 259 400 CONTINUE 260 PROMPT = WORD(1:1) 261 IF (PROMPT .EQ. '!' .OR. PROMPT .EQ. '#') THEN 262 GO TO 400 263 ELSE IF (PROMPT .EQ. '*') THEN 264 DO 500 I = 1, NDIR 265 IF (WORD .EQ. TABDIR(I)) THEN 266 GO TO 267 * (101,102,103), I 268 END IF 269 500 CONTINUE 270 IF (WORD(1:2) .EQ. '**') GO TO 600 271 WRITE (LUPRI,'(/,3A,/)') ' Directory ',WORD,' nonexistent.' 272 CALL PRTAB(NDIR,TABDIR,WORD1//' input keywords',LUPRI) 273 CALL QUIT('Illegal directory in ABAINP.') 274 ELSE 275 WRITE (LUPRI,'(/,3A,/)') ' Prompter "',PROMPT,'" illegal or', 276 * ' out of order.' 277 CALL PRTAB(NDIR,TABDIR,WORD1//' input keywords',LUPRI) 278 CALL QUIT('Program stopped in ABAINP, error in prompt.') 279 END IF 280 101 CONTINUE ! *PROPAV 281 CALL NVBINP(WORD) 282 GOTO 400 283 102 CONTINUE 284 GOTO 400 285 103 CONTINUE ! *VIBANA 286 CALL VIBINP(WORD) 287 GOTO 400 288C 289 600 CONTINUE 290C 291 RETURN 292 END 293C 294C /* Deck fndana */ 295 SUBROUTINE FNDANA(NAORDR) 296C ******************************************************* 297C **** Subroutine that keeps track of the analytical **** 298C **** for a given wave-function. NAORDR gives the **** 299C **** order of the analytical derivative. **** 300C ******************************************************* 301 use pelib_interface, only: use_pelib 302#include "implicit.h" 303#include "priunit.h" 304#include "maxorb.h" 305C 306 PARAMETER (D0 = 0.0D0) 307#include "gnrinf.h" 308#include "inforb.h" 309#include "dftcom.h" 310#include "ecpinf.h" 311#include "ccsdinp.h" 312 LOGICAL WAVTP ! external function 313 LOGICAL MCSCF, DMP2, DPCM, DOROSCF, DONEVPT 314 LOGICAL DOHFSRDFT, DOCISRDFT, DOMCSRDFT 315C 316C *** Workaround to many common variables with the same name *** 317C *** MCSCF is set to DOMC (in infinp.h), and DMP2 is set *** 318C *** to DOMP2 (in infinp.h through the logical function *** 319C *** WAVTP. *** 320C 321 MCSCF = WAVTP('MCSCF') 322 DMP2 = WAVTP('MP2') 323 DPCM = WAVTP('PCM') 324 DOROSCF = WAVTP('ROHF') 325 DONEVPT = WAVTP('NEVPT') 326#ifdef MOD_SRDFT 327 DOHFSRDFT = WAVTP('HFSRDFT') 328 DOCISRDFT = WAVTP('CISRDFT') 329 DOMCSRDFT = WAVTP('MCSRDFT') 330#else 331 DOHFSRDFT = .FALSE. 332 DOCISRDFT = .FALSE. 333 DOMCSRDFT = .FALSE. 334#endif 335C 336 IF (CCSDT .OR. CIS .OR. CC1A .OR. CC1B .OR. MCC2 .OR. CCP2 .OR. 337 & CC3 .OR. CCP3 .OR. CCRT .OR. CCR3 .OR. 338 & CCR1A .OR. CCR1B .OR. CCT .OR. 339 & (DOROSCF .AND. NSYM.gt.1 .AND. .NOT.DIRCAL) .OR. ! high spin HF or DFT, with symmetry 340 & DOHFSRDFT .OR. DOCISRDFT .OR. DOMCSRDFT .OR. DONEVPT .OR. 341 & (DMP2.AND..NOT.MCSCF) .OR. ECP .OR. DKTRAN) THEN 342 NAORDR = 0 343 ELSE IF (CCD. OR. CCSD .OR. CCS .OR. CC2 .OR. MP2 .OR. CCPT .OR. ! MP2 is MP2 from CC code 344 & DOROSCF .OR. ! high spin HF or DFT, no symmetry 345 & (DFTRUN .AND. (NSYM.GT.1.OR.HFXMU.NE.D0)) .OR. 346 & DRCCD .OR. SOSEX .OR. RCCD .OR. !RPA Methods with analytic gradient only 347 & DPCM .OR. 348 & DODFTD .OR. !AMT Only gradients for empirical disp correction so far 349 & USE_PELIB()) THEN 350 NAORDR = 1 351 ELSE 352 NAORDR = 2 353 END IF 354C 355 RETURN 356 END 357C 358C /* Deck wavtp */ 359 LOGICAL FUNCTION WAVTP(STRING) 360C ************************************************************** 361C *** Workaround to many common variables with the same name *** 362C *** MCSCF is set to DOMC (in infinp.h) through the logical *** 363C *** function WAVTP. *** 364C ************************************************************** 365#include "implicit.h" 366#include "priunit.h" 367#include "maxorb.h" 368#include "pcmlog.h" 369#include "infinp.h" 370 CHARACTER*(*) STRING 371C 372 IF (STRING.EQ.'MCSCF') THEN 373 WAVTP = DOMC 374 ELSE IF (STRING.EQ.'MP2') THEN 375 WAVTP = DOMP2 376 ELSE IF (STRING.EQ.'ROHF') THEN 377 WAVTP = HSROHF 378 ELSE IF (STRING.EQ.'NEVPT') THEN 379 WAVTP = DONEVPT 380#ifdef MOD_SRDFT 381 ELSE IF (STRING.EQ.'HFSRDFT') THEN 382 WAVTP = DOHFSRDFT 383 ELSE IF (STRING.EQ.'CISRDFT') THEN 384 WAVTP = DOCISRDFT 385 ELSE IF (STRING.EQ.'MCSRDFT') THEN 386 WAVTP = DOMCSRDFT 387#endif 388 ELSE IF (STRING.EQ.'PCM') THEN 389 WAVTP = PCM 390 ELSE 391 WRITE (LUPRI,'(/2A)') 392 & 'Undefined string in WAVTP :', STRING 393 CALL QUIT('Wrong string in WAVTP') 394 END IF 395! write(lupri,'(2A,T30,A,L10)') 396! & 'WAVE FUNCTION TYPE ', STRING,' : ', WAVTP 397C 398 RETURN 399 END 400C 401C 402C /* Deck nmdini */ 403 SUBROUTINE NMDINI(IPRINT) 404C 405C Initialize /NUMDER/, /FCSYM/ and some /ABAINF/ 406C 407#include "implicit.h" 408#include "mxcent.h" 409#include "numder.h" 410#include "pgroup.h" 411#include "fcsym.h" 412#include "cbinum.h" 413#include "abainf.h" 414#include "cbiwlk.h" 415C 416C Print variable. 417 IPRINT = 0 418C 419C /CBINUM/ 420 NRMCRD = .FALSE. 421 PGMTST = .FALSE. 422 HTEST = .FALSE. 423 PREHES = .FALSE. 424 REUHES = .FALSE. 425 ANALZ1 = .FALSE. 426 NUMVIB = .FALSE. 427 NPRPDR = .FALSE. 428 HARMON = .FALSE. 429 SPECTR = .FALSE. 430 MIDAS = .FALSE. 431 MINOUT = .FALSE. 432 THRMID = 1.0D-15 433C 434C /NUMDER/ 435 NMORDR = 0 436 NAORDR = 0 437 NMDPRP = 0 438 NMRDRP = 0 439 NARDRP = 0 440 NMPINI = 0 441 NWPROP = .FALSE. 442 FSTPRP = .FALSE. 443 NOMOVE = .FALSE. 444 NUMELC = .FALSE. 445 CMPARE = .FALSE. 446 SDRTST = .FALSE. 447 DRYRUN = .FALSE. 448 FRSTNM = .FALSE. 449 PRPVIB = .FALSE. 450 MANUAL = .FALSE. 451CRF added 452 PRPONL = .FALSE. 453 PRPBAS = .FALSE. 454 C4FORC = .FALSE. 455C 456C /FCSYM/ 457CRF We initialize the numdiff symmetry to the computational point group 458C FCLASS(1:3) = GROUP 459 FCLASS(1:3) = 'C1 ' 460 FCLASS(4:15) = ' ' 461 MROTAX = .FALSE. 462 VPLANE = .FALSE. 463 HPLANE = .FALSE. 464 ROTAX2 = .FALSE. 465 DPLANE = .FALSE. 466 ICNTR = .FALSE. 467 ROTARE = .FALSE. 468 SEPDEG = .FALSE. 469C 470C /ABAINF/ 471 VIB = .FALSE. 472C 473C /CBIWLK/ 474 DISPLC = 1.0D-2 475C 476 RETURN 477 END 478C 479C 480C /* Deck numdrv */ 481 SUBROUTINE NUMDRV(WORK,LWORK,IPRINT,WRKDLM) 482C 483C Driver routine for numerical differentiation 484C 485 486#include "implicit.h" 487#include "priunit.h" 488#include "mxcent.h" 489#include "maxaqn.h" 490#include "maxorb.h" 491#include "infpar.h" 492C 493c#if defined (VAR_MPI) 494c INCLUDE 'mpif.h' 495c LOGICAL FINISH 496c#endif 497#include "cbirea.h" 498#include "cbiwlk.h" 499#include "cbinum.h" 500#include "trkoor.h" 501#include "nuclei.h" 502#include "symmet.h" 503#include "numder.h" 504#include "molinp.h" 505#include "fcsym.h" 506#include "gnrinf.h" 507#include "huckel.h" 508 DIMENSION WORK(LWORK) 509 LOGICAL MOLECU 510 CHARACTER WORD*7 511C 512 CALL QENTER('NUMDRV') 513C 514C feb 11 - hjaaj 515C cut down on hermit and abacus output during numerical 516C differentiation 517C 518 IPRUSR_orig = IPRUSR 519 IPREAD_orig = IPREAD 520 IF (USRIPR) THEN 521C if user has asked for higher print level, no change 522 IPRUSR_reduced = IPRUSR 523 IPREAD_reduced = IPREAD 524 ELSE 525 IPRUSR_reduced = -2 526 IPREAD_reduced = -2 527 END IF 528 IPRUSR = IPRUSR_reduced 529 IPREAD = IPREAD_reduced 530C 531 100 CONTINUE 532C 533 MOLECU = .TRUE. 534 NCOOR = 3*NUCDEP 535C 536 NDERIV = 0 537 NDIME = 1 538 NINNER = 1 539 IF (NAORDR.GE.1) NINNER = NCOOR*NINNER 540 IF (NAORDR.GE.2) NINNER =(NCOOR+1)*NINNER/2 541 NINNER = NINNER + 3 ! make space for dipole moment derivatives 542C 543 MAXADR = 1 544 DO 200 J = NMORDR, 1, -2 545 IF (J .GT. 0) MAXADR = MAXADR + J 546 200 CONTINUE 547C 548C NDERIV -> number derivatives to save space 549C for in WORK 550 DO 300 IORDR = 3, NMORDR+NAORDR 551 IKDRV = 1 552 DO 400 IIORDR = 1, IORDR 553 IKDRV = IKDRV*(NCOOR+IIORDR-1)/IIORDR 554 400 CONTINUE 555 NDERIV = NDERIV + IKDRV 556 300 CONTINUE 557C 558 DO 500 IORDR = 1, NMORDR 559 IKDIME = 1 560 DO 600 IIORDR = 1, IORDR 561 IKDIME = IKDIME*(NCOOR+1-IIORDR)/IIORDR 562 600 CONTINUE 563 NDIME = NDIME + IKDIME*2**IORDR 564 500 CONTINUE 565 IF (NMORDR .GE. 3) THEN 566 NDIME = NDIME + 2*NCOOR 567 END IF 568 IF (NMORDR .GE. 4) THEN 569 NDIME = NDIME + 4*NCOOR*(NCOOR-1) 570 END IF 571 IF (NMORDR .GE. 5) THEN 572 NDIME = NDIME + 2*NCOOR 573 END IF 574C 575 KTEST = 2 576Chjaaj-Oct07: KTEST a simple device to check if arrays which 577C supposedly not are used, are used anyway. 578 KDERIV = KTEST + 1 579 KFUNVAL = KDERIV + NDERIV 580 KCOOR = KFUNVAL + NDIME*NINNER 581 KCSTAR = KCOOR + 3*NCOOR 582 KSYMCO = KCSTAR + 3*NCOOR 583 KTRNRC = KSYMCO + NCOOR**2 584 KTRMSS = KTRNRC + NCOOR**2 585 KDKIN = KTRMSS + NCOOR 586 KFREQ = KDKIN + NCOOR 587 KRNNRM = KFREQ + NCOOR 588 KLAST = KRNNRM + NCOOR 589C 590C *** Memory needed for test on Hessian. *** 591C 592 IF (SDRTST) THEN 593 KTSTGD = KLAST 594 KTSTSD = KTSTGD + NCOOR 595 KLAST = KTSTSD + NCOOR**2 596 ELSE 597 KTSTGD = KTEST 598 KTSTSD = KTEST 599 END IF 600 IF (PGMTST) THEN 601 LTHTST = 2**NMORDR 602 KENTST = KLAST 603 KLAST = KENTST + LTHTST 604 ELSE 605 KENTST = KTEST 606 END IF 607C 608C *** Memory for screening of rendundant force constants. *** 609C 610 LDPMTX = 0 611 IF (NMORDR .GE. 4) THEN 612 LDPMTX = LDPMTX + (NCOOR*(NCOOR+1)*(NCOOR+2)*(NCOOR+3))/24 613 END IF 614 IF (NMORDR .GE. 3) THEN 615 LDPMTX = LDPMTX + (NCOOR*(NCOOR+1)*(NCOOR+2))/6 616 END IF 617CRF 618 NSTRDR = MAX( NMORDR, NMRDRP) + 1 619C ... hjaaj Dec 07: used for allocation, and NMORDR+1 is sometimes referenced 620 IF (NMORDR .GE. 2) THEN 621 IFRSTD = 2**NMORDR 622 LDPMTX = LDPMTX + (NCOOR*(NCOOR+1))/2 623 KDPMTX = KLAST 624chj KDCOEF = KDPMTX + IFRSTD*NMORDR*LDPMTX 625 KDCOEF = KDPMTX + IFRSTD*NSTRDR*LDPMTX 626 KNIDPC = KDCOEF + IFRSTD *LDPMTX 627 KLAST = KNIDPC + LDPMTX 628 ELSE 629 KDPMTX = KTEST 630 KDCOEF = KTEST 631 KNIDPC = KTEST 632 END IF 633C 634C *** Space for backup of isotopes if abacus is run. *** 635C 636 IF (NAORDR.GT.0) THEN 637 KISOTP = KLAST 638 KLAST = KISOTP + NUCDEP 639 ELSE 640 KISOTP = KTEST 641 END IF 642C 643C *** Symmetry initialization and symmetry *** 644C *** related memory allocation *** 645C 646 CALL FCSINI 647 KGRIRP = KLAST 648 KCHRCT = KGRIRP + NGORDR*NGVERT 649 KICRIR = KCHRCT + NGORDR*NCVERT 650 KLAST = KICRIR + 2*NCOOR 651C 652 LWRK1 = LWORK - KLAST + 1 653C 654Chjaaj-Oct07: KTEST is a simple device to check if arrays which 655C supposedly not are used, are used anyway. 656 WORK(KTEST) = -999.9D0 657 CALL NUMDR1(WORK(KDERIV),WORK(KFUNVAL),WORK(KCOOR),WORK(KCSTAR), 658 & WORK(KSYMCO),WORK(KDCOEF),WORK(KTSTGD),WORK(KTSTSD), 659 & WORK(KENTST),WORK(KGRIRP),WORK(KCHRCT),WORK(KTRNRC), 660 & WORK(KTRMSS),WORK(KDKIN) ,WORK(KFREQ), WORK(KRNNRM), 661 & WORK(KLAST) ,WORK(KDPMTX),WORK(KNIDPC),WORK(KICRIR), 662 & WORK(KISOTP),LWRK1,NDERIV,NDIME, 663 & NINNER,MAXADR,LTHTST,LDPMTX,IFRSTD,IPRINT,WRKDLM) 664 IF (WORK(KTEST) .NE. -999.9D0) THEN 665 CALL QUIT('WORK(KTEST) has been modified!') 666 END IF 667C 668C 669c#if defined (VAR_MPI) 670cC 671cC We let the slaves wait for the Master to tell them whether to pick up 672cC a new geometry or to end this calculation 673cC 674c IF (MYNUM .GT. 0) THEN 675c CALL MPI_BCAST(NTASK,1,my_MPI_INTEGER,MASTER, 676c & MPI_COMM_WORLD,IERR) 677c IF (NTASK .EQ. 1) THEN 678c CALL PARION 679c RDINPC = .FALSE. 680c CALL READIN(WORK,LWORK,.FALSE.) 681c GOTO 100 682c ELSE IF (NTASK .EQ. 0) THEN 683c CALL MPI_BCAST(FINISH,1,my_MPI_LOGICAL,MASTER, 684c & MPI_COMM_WORLD,IERR) 685c CALL MPI_FINALIZE(IERR) 686c CALL SYSTEM('rm -f $SCRATCHDIR/*') 687c STOP '*** End of DALTON calculation ***' 688c ELSE 689c WRITE (LUPRI,'(/A)') 'Unknown message received by slave' 690c CALL QUIT('Slave received unknown message from master') 691c END IF 692c END IF 693c#endif 694C 695C 696C 697CRF 6/12 12 Rerun NUMDR1 with new basis set, to get properties 698CRF with a different basis set 699 IF ( PRPBAS .AND. .NOT. PRPONL ) THEN 700C Resetting variables for property derivatives 701 REUHES = .FALSE. 702 NUMVIB = .FALSE. 703 NPRPDR = .TRUE. 704 PREHES = .TRUE. 705 PRPVIB = .TRUE. 706 FRSTNM = .TRUE. 707 NMRDRP = NMRDBK 708 NARDRP = NARDBK 709 NMORDR = 2 !Still need to keep this 710 NAORDR = 0 711 PRPONL = .TRUE. 712 713C Better tell people, what we are doing 714 WRITE (LUPRI,'(//80A1/)') ('*' , I = 1,80) 715 CALL TITLER('@ Calculating property derivatives.','*',124) 716 CALL TITLER('@ Basis set changed to '//PRPBTX,'*',103) 717 718C Setting basis set line in .mol file to property basis 719 IF (NMLINE_basis .eq. NMLINE_1+1) THEN 720 MLINE(NMLINE_basis) = PRPBTX 721 ELSE IF (NMLINE_basis .eq. NMLINE_1) THEN 722 MLINE(NMLINE_basis) = 'BASIS '//PRPBTX 723 ELSE 724 WRITE(LUPRI,'(/A)') '.mol file error for .P-BASIS' 725 WRITE(LUPRI,*)'Line number with basis set info',NMLINE_basis 726 IF (NMLINE_basis.gt.0) WRITE(LUPRI,*) MLINE(NMLINE_basis) 727 CALL QUIT('.mol file error for .P-BASIS') 728 END IF 729 730C Rerun NUMDR1 + Preceeding memory allocations 731 GOTO 100 732 END IF 733CRFend 734C 735C *** No more numerical derivatives. *** 736 NMWALK = .FALSE. 737 IPRUSR = IPRUSR_orig 738 IPREAD = IPREAD_orig 739C 740 CALL QEXIT('NUMDRV') 741 RETURN 742 END 743C 744C /* Deck numdr1 */ 745 SUBROUTINE NUMDR1(DERIV,FUNVAL,COOR,CSTART,SYMCOR,DCOEFF,TSTGDR, 746 & TSTSDR,ENTST,GRIREP,CHRCTR,TRNCCR,TRAMSS,DKIN, 747 & FREQ,RNNORM,WORK,KDPMTX,NMIDPC,ICRIRP,ISOTMP, 748 & LWORK,NDERIV,NDIME,NINTIN,MAXADR, 749 & LTHTST,LDPMTX,IFRSTD,IPRINT,WRKDLM) 750#include "implicit.h" 751#include "priunit.h" 752#include "dummy.h" 753#include "mxcent.h" 754#include "maxaqn.h" 755#include "maxorb.h" 756#include "infpar.h" 757 PARAMETER (D0 = 0.0D0) 758#include "cbiwlk.h" 759#include "cbinum.h" 760#include "nuclei.h" 761#include "symmet.h" 762#include "exeinf.h" 763#include "abainf.h" 764#include "trkoor.h" 765#include "numder.h" 766#include "prpndr.h" 767#include "past.h" 768#include "gnrinf.h" 769#include "inftap.h" 770#include "molinp.h" 771#include "fcsym.h" 772 LOGICAL EXHER, EXSIR, EXABA, RSTDON, SYMDET, NPRBKP, 773 & NSPNBK 774 CHARACTER*(len_MLINE) MBKLIN(NMLINE) ! automatic array for backup of MLINE 775 CHARACTER*8 ANDER, PRTEXT 776 CHARACTER*6 TXT 777 DIMENSION DERIV(NDERIV), FUNVAL(NINTIN,NDIME), CSTART(3*NCOOR), 778 & COOR(3*NCOOR), SYMCOR(NCOOR,NCOOR), 779 & DCOEFF(LDPMTX,IFRSTD), TSTGDR(NCOOR), ENTST(LTHTST), 780 & TSTSDR(NCOOR,NCOOR), GRIREP(NGORDR,NGVERT), 781 & CHRCTR(NGORDR,NCVERT), TRNCCR(NCOOR,NCOOR), 782 & TRAMSS(NCOOR), DKIN(NCOOR), FREQ(NCOOR), RNNORM(NCOOR), 783 & ISOTMP(NATOMS), WORK(LWORK) 784 DIMENSION ICRIRP(NCOOR,2), KDPMTX(LDPMTX,NSTRDR,IFRSTD), 785 & NMIDPC(LDPMTX) 786 787C 788C ****************************** 789C *** Restart initialization *** 790C ****************************** 791C 792 RSTDON = .FALSE. 793C 794C ***************************************** 795C *** Backing up symmetry for later use *** 796C ***************************************** 797C 798 CALL BKSMNM 799c CALL DALCHG(DUMMY,IDUMMY,IDUMMY,IPRINT,IDUMMY,IDUMMY,.TRUE.) 800C 801C ************************************* 802C ***Backup of original MOLECULE.INP*** 803C *** To finish off correctly. *** 804C ************************************* 805C 806 NMBKLN = NMLINE 807 DO 100 IMLINE = 1, NMLINE 808 MBKLIN(IMLINE) = MLINE(IMLINE) 809 100 CONTINUE 810C 811C ********************************************* 812C *** Backup of isotopes, if abacus is run. *** 813C ********************************************* 814C 815 IF (NAORDR.GT.0) THEN 816 CALL ICOPY(NATOMS,ISOTOP,1,ISOTMP,1) 817 END IF 818C 819C **************************************** 820C ***Unrolling the symmetry coordinates*** 821C *** In order to take proper steps *** 822C **************************************** 823C 824 ICOOR = 0 825 IATOM = 0 826 DO 200 ICENT = 1, NUCIND 827 MULCNT = ISTBNU(ICENT) 828 DO 300 IOP = 0, MAXOPR 829 IF (IAND(IOP,MULCNT) .EQ. 0) THEN 830 IATOM = IATOM + 1 831 DO 400 I = 1, 3 832 ICOOR = ICOOR + 1 833 CSTART(ICOOR) = 834 & PT(IAND(ISYMAX(I,1),IOP))*CORD(I,ICENT) 835 400 CONTINUE 836 END IF 837 300 CONTINUE 838 200 CONTINUE 839C 840C *** Restart *** 841C 842 LURSTR = -1 843 CALL GPOPEN(LURSTR,'RSTRT.FC','UNKNOWN',' ','FORMATTED',IDUMMY, 844 & .FALSE.) 845 REWIND(LURSTR) 846 IF (NPRPDR) THEN 847 LUNDPR = -1 848 CALL GPOPEN(LUNDPR,'PROPERTY.NDER','UNKNOWN',' ','FORMATTED', 849 & IDUMMY,.FALSE.) 850 REWIND(LUNDPR) 851 END IF 852C 853 IF (RESTRT) THEN 854C 855C *** Restart, find which round it ended *** 856C *** in this run of nmder. Reread fuval *** 857C *** values from file. *** 858C 859 KEND = 0 860 IDIMAX = 0 861 IDIMIN = 2 862 CALL RERSTR(FUNVAL,SYMCOR,VDUMMY,VDUMMY,ICRIRP,NDIME,NINTIN, 863 & KEND,IDIMAX,IDIMIN,LURSTR,IPRINT,RSTDON) 864C 865C *** Restart for property derivatives. *** 866C 867 IF (NPRPDR.AND..NOT.NRMCRD) THEN 868 KSTRT = 2 869 LWRK1 = LWORK - KSTRT 870 CALL PRPRER(WORK(KSTRT),IDIMAX,IDIMIN,LURSTR,LWRK1) 871 END IF 872 ELSE 873C 874C *** Open restart file. A zero first in the file *** 875C *** means that the calculation ended here. *** 876C 877 WRITE (LURSTR,'(I2)') 0 878 END IF 879C 880 NUMCAL = 0 881 SYMDET = .TRUE. 882 NDCOOR = NCOOR 883 IF (NRMCRD) THEN 884 NTMPDR = NMORDR 885 NMORDR = 2 - NAORDR 886 IF ((NAORDR+NMORDR).LT.2) NMORDR = NTMPDR 887 END IF 888 MAXINR = 2**NMORDR 889C 890 IF (.NOT.(PREHES.AND.NRMCRD)) THEN 891 IF (PREHES) WRITE (LUPRI,'(/A)') ' Not able to use a' // 892 & ' precalculated hessian, since normal coordinates' // 893 & ' are not specified.' 894C 895C *** If normal coordinates then no property derivatives *** 896C *** should be calculated at this time. *** 897C 898 IF (NRMCRD) THEN 899C 900C *** First time through. *** 901C 902 FRSTNM = .TRUE. 903C 904C *** If normal coordinates then no *** 905C *** property derivatives should be *** 906C *** calculated at this time. *** 907C 908 NPRBKP = NPRPDR 909 NPRPDR = .FALSE. 910 NSPNBK = NSPNSP 911 NSPNSP = .FALSE. 912C 913 END IF 914C 915 KIADRS = 2 916 KINDST = KIADRS + MAXADR 917 KNPRTN = KINDST + NMORDR 918 KINDTM = KNPRTN + NMORDR 919 NTORDR = NMORDR 920C ... NTORDR is used for DIMENSION in NMDER /hjaaj 921 KIDCMP = KINDTM + MAXINR 922 KIEQVG = KIDCMP + NCOOR 923 KICIN = KIEQVG + 2*NMORDR 924 KIRPID = KICIN + NMORDR 925 KEGRAD = KIRPID + NMORDR 926 KEHESS = KEGRAD + MXCOOR 927c#if defined (VAR_MPI) 928c KFTVAL = KEHESS + MXCOOR**2 929c KLAST = KFTVAL + NDIME 930c#else 931 KLAST = KEHESS + MXCOOR**2 932c#endif 933C 934 LWRK = LWORK - KLAST + 1 935C 936 CALL NMDER(DERIV,FUNVAL,COOR,CSTART,SYMCOR,ENTST,DCOEFF,GRIREP, 937 & CHRCTR,WORK(KEGRAD),WORK(KEHESS),WORK(KLAST),ICRIRP, 938 & KDPMTX,NMIDPC,WORK(KIADRS),WORK(KINDST),WORK(KINDTM), 939 & WORK(KNPRTN),WORK(KIDCMP),WORK(KIEQVG),WORK(KICIN), 940 & WORK(KIRPID),MBKLIN,NMBKLN,NDERIV,LWRK,NDIME,NINTIN, 941 & MAXADR,LDPMTX,IFRSTD,MAXINR,LTHTST,IDIMAX,IDIMIN, 942 & LURSTR,IPRINT,WRKDLM, 943c#if defined (VAR_MPI) 944c & WORK(KFTVAL),SYMDET,RSTDON) 945c#else 946 & SYMDET,RSTDON) 947c#endif 948C 949C *** Restoring property derivatives. *** 950C 951 IF (NRMCRD) THEN 952 NPRPDR = NPRBKP 953 NSPNSP = NSPNBK 954 END IF 955C 956C ******************************************* 957C *** Restore isotopes, if abacus is run. *** 958C ******************************************* 959C 960 IF (NAORDR.GT.0) THEN 961 CALL ICOPY(NATOMS,ISOTMP,1,ISOTOP,1) 962 END IF 963 964 ELSE 965 WRITE (LUPRI,'(/A/)') 'Reading in precalculated hessian' 966C 967 KHSSIN = 1 968 KLAST = KHSSIN + NCOOR**2 969 LWRK = LWORK - KLAST + 1 970 CALL RDHESS(SYMCOR,CSTART,GRIREP,CHRCTR,WORK(KHSSIN), 971 & WORK(KLAST),ICRIRP,LWRK,IPRINT,SYMDET) 972 END IF 973C 974C *** Resetting some variables. *** 975C 976 IF (NRMCRD) THEN 977 NMORDR = NTMPDR 978 END IF 979C 980C *** Close the restart file *** 981C 982 CALL GPCLOSE(LURSTR,'KEEP') 983C 984C *** Printing the derivatives *** 985C 986 IF (MYNUM.EQ.0) THEN 987 LTEXT = 8 988 PRTEXT(1:8) = 'symmetry' 989 IF (NRMCRD) THEN 990 NPRRDR = 2 991 ELSE 992 NPRRDR = NMORDR+NAORDR 993 END IF 994 NDIMT = NCOOR*(NCOOR+1)*(NCOOR+2)/6 995 NDIMF = NCOOR*(NCOOR+1)*(NCOOR+2)*(NCOOR+3)/24 996 KTDRS = 1 997 KFDRS = KTDRS + NDIMT 998C 999 KTTMPD = 2 1000 KFTMPD = KTTMPD + NCOOR**3 1001 KLAST = KFTMPD + NCOOR**4 1002 LWRK = LWORK - KLAST + 1 1003C 1004C PRDERV not only prints, but calculates also the correct GRDMOL and HESMOL when symmetry 1005c 1006 CALL PRDERV(DERIV(KTDRS),DERIV(KFDRS),TSTGDR,TSTSDR,SYMCOR, 1007 & CSTART,WORK(KTTMPD),WORK(KFTMPD),RNNORM,WORK(KLAST),ICRIRP, 1008 & LWRK,NPRRDR,NDIMT,NDIMF,LTEXT,IPRINT,PRTEXT) 1009C 1010 IF (SDRTST) THEN 1011 KTMPGD = 2 1012 KTMPHS = KTMPGD + MXCOOR 1013 KLAST = KTMPHS + NCOOR**2 1014 LWRK = LWORK - KLAST + 1 1015 IF (KLAST.GT.LWORK) CALL QUIT('Memory exceeded in SDERTT') 1016 CALL SDERTT(TSTSDR,TSTGDR,SYMCOR,WORK(KTMPGD),WORK(KTMPHS), 1017 & WORK(KLAST),LWRK, WRKDLM,IPRINT) 1018 END IF 1019C 1020C *** Reevaluate restart parameter *** 1021C 1022 IF (RESTRT.AND.RSTDON) THEN 1023 RESTRT = .FALSE. 1024 RSTDON = .FALSE. 1025 END IF 1026C 1027C 1028 IF ( ((NAORDR+NMORDR).GT.1) .OR. PRPONL ) THEN 1029 IF (DRYRUN) THEN 1030 CALL DRNRMC(SYMCOR,ICRIRP,IPRINT) 1031 ELSE 1032 IF (HARMON) THEN 1033 KTRAMT = 2 1034 KTMPHS = KTRAMT + NCOOR**2 1035 KLAST = KTMPHS + NCOOR**2 1036 LWRK = LWORK - KLAST + 1 1037 CALL HARMAN(SYMCOR,WORK(KTRAMT), 1038 & WORK(KTMPHS),WORK(KLAST),NCOOR,LWRK, 1039 & IPRINT) 1040 END IF 1041C 1042 IF (PREHES.AND..NOT.NRMCRD) THEN 1043 KHSSIN = 1 1044 KLAST = KHSSIN + NCOOR**2 1045 LWRK = LWORK - KLAST + 1 1046 CALL RDHESS(SYMCOR,CSTART,GRIREP,CHRCTR,WORK(KHSSIN), 1047 & WORK(KLAST),ICRIRP,LWRK,IPRINT,SYMDET) 1048 END IF 1049C 1050C *** If we are not doing things in normal coordinates *** 1051C *** we need to save the symmetry coordinates. *** 1052C 1053 IF (.NOT. NRMCRD) THEN 1054 KSYCAR = 2 1055 KEIGNV = KSYCAR + NCOOR**2 1056 CALL DCOPY(NCOOR**2,SYMCOR,1,WORK(KSYCAR),1) 1057 ELSE 1058 KEIGNV = 2 1059 END IF 1060C 1061 IF (.NOT.RESTRT) THEN 1062 KEGNVC = KEIGNV + NCOOR 1063 KHSMWT = KEGNVC + NCOOR**2 1064 KMT1TP = KHSMWT + NCOOR*(NCOOR+1)/2 1065 KMT2TP = KMT1TP + NCOOR**2 1066 KAMASS = KMT2TP + NCOOR**2 1067 KHTSTM = KAMASS + NATOMS 1068 KNATYP = KHTSTM + NCOOR**2 1069 KNMSSP = KNATYP + NATOMS 1070 KCRTMP = KNMSSP + NCOOR 1071 KLAST = KCRTMP + NCOOR 1072C 1073 LWRK = LWORK - KLAST + 1 1074 IF (KLAST.GT.LWORK) 1075 & CALL QUIT('Memory exceeded in MKNRMC') 1076 ! Make normal coordinates 1077 CALL MKNRMC(SYMCOR,CSTART,TRNCCR,TRAMSS,WORK(KEIGNV), 1078 & WORK(KEGNVC),WORK(KHSMWT),WORK(KMT1TP), 1079 & WORK(KMT2TP),WORK(KAMASS),DKIN,WORK(KHTSTM),FREQ, 1080 & RNNORM,WORK(KCRTMP),WORK(KLAST),ICRIRP, 1081 & WORK(KNATYP),WORK(KNMSSP),LWRK,IPRINT) 1082 END IF 1083C 1084C *** Debug printing. *** 1085C 1086 IF (.NOT.NRMCRD.AND.(IPRINT.GE.50)) THEN 1087 NDIMT = NCOOR*(NCOOR+1)*(NCOOR+2)/6 1088 NDIMF = NCOOR*(NCOOR+1)*(NCOOR+2)*(NCOOR+3)/24 1089 KTDRS = 1 1090 KFDRS = KTDRS + NDIMT 1091C 1092 KSYCAR = 2 1093 KHSNRM = KSYCAR + NCOOR**2 1094 KCRTNM = KHSNRM + NCOOR**2 1095 KTNRMD = KCRTNM + NCOOR**2 1096 KFNRMD = KTNRMD + NCOOR**3 1097 KLAST = KFNRMD + NCOOR**4 1098 LWRK = LWORK - KLAST + 1 1099C 1100 CALL TRAFRC(DERIV(KTDRS),DERIV(KFDRS),WORK(KHSNRM), 1101 & SYMCOR,WORK(KCRTNM),WORK(KSYCAR), 1102 & WORK(KTNRMD),WORK(KFNRMD),WORK(KLAST), 1103 & NCOOR,NDIMF,NDIMT,LWRK,IPRINT) 1104 END IF 1105 END IF 1106 END IF 1107 END IF ! (MYNUM.EQ.0) 1108C 1109CRF Also need to take this branch if we evaluate property derivatives only 1110 IF (NRMCRD .AND. ( ((NAORDR+NMORDR).GT.2) .OR. PRPONL ) ) THEN 1111 FRSTNM = .FALSE. 1112C 1113C *** Restart *** 1114C 1115 LURSTR = -1 1116 CALL GPOPEN(LURSTR,'RSTRT.FC','UNKNOWN',' ','FORMATTED',IDUMMY, 1117 & .FALSE.) 1118 REWIND(LURSTR) 1119C 1120 IF (RESTRT) THEN 1121C 1122C *** Restart, find which round it ended *** 1123C *** in this run of nmder. Reread fuval *** 1124C *** values and normal coordinates from *** 1125C *** file. *** 1126C 1127 KEND = 1 1128 IDIMAX = 0 1129 IDIMIN = 2 1130 CALL RERSTR(FUNVAL,SYMCOR,RNNORM,FREQ,ICRIRP,NDIME,NINTIN, 1131 & KEND,IDIMAX,IDIMIN,LURSTR,IPRINT,RSTDON) 1132C 1133C *** Restart for property derivatives. *** 1134C 1135 IF (NPRPDR) THEN 1136 KSTRT = 2 1137 LWRK1 = LWORK - KSTRT 1138 CALL PRPRER(WORK(KSTRT),IDIMAX,IDIMIN,LURSTR,LWRK1) 1139 END IF 1140C 1141C *** Writing to spectro file if requested. *** 1142C 1143 IF (SPECTR) THEN 1144 NTIME = 1 1145 IF (NRMCRD) THEN 1146 TXT = 'normal' 1147 ELSE 1148 TXT = 'cartes' 1149 END IF 1150 CALL WRISPC(FREQ,RNNORM,VDUMMY,VDUMMY,TXT,NCOOR,NDCOOR, 1151 & NTIME,IPRINT) 1152 END IF 1153 IF (MIDAS) THEN 1154 NTIME = 1 1155 IF (NRMCRD) THEN 1156 TXT = 'normal' 1157 ELSE 1158 TXT = 'cartes' 1159 END IF 1160 IF (NRMCRD) CALL WRIMOP(FREQ,RNNORM,VDUMMY,VDUMMY,TXT, 1161 & NCOOR,NDCOOR,NTIME,IPRINT) 1162 END IF 1163 ELSE 1164C 1165C *** Open restart file. A 1 first in the file *** 1166C *** means that the calculation ended here. *** 1167C *** Normal coordinates are also written to *** 1168C *** file for restart purposes. *** 1169C 1170 WRITE (LURSTR,'(I2)') 1 1171 CALL WRICOR(SYMCOR,RNNORM,FREQ,ICRIRP,LURSTR,IPRINT) 1172 END IF 1173C 1174 MAXINR = 2**NMORDR 1175 NTORDR = NMORDR+NAORDR 1176C 1177 KIADRS = 2 1178 KINDST = KIADRS + MAXADR 1179 KNPRTN = KINDST + NTORDR 1180 KINDTM = KNPRTN + NTORDR 1181 KIDCMP = KINDTM + MAXINR 1182 KIEQVG = KIDCMP + NCOOR 1183 KICIN = KIEQVG + 2*NMORDR 1184 KIRPID = KICIN + NMORDR 1185 KEGRAD = KIRPID + NMORDR 1186 KEHESS = KEGRAD + MXCOOR 1187c#if defined (VAR_MPI) 1188c KFTVAL = KEHESS + MXCOOR**2 1189c KLAST = KFTVAL + NDIME 1190c#else 1191 KLAST = KEHESS + MXCOOR**2 1192c#endif 1193 1194C 1195 LWRK = LWORK - KLAST + 1 1196C 1197 CALL NMDER(DERIV,FUNVAL,COOR,CSTART,SYMCOR,ENTST,DCOEFF,GRIREP, 1198 & CHRCTR,WORK(KEGRAD),WORK(KEHESS),WORK(KLAST),ICRIRP, 1199 & KDPMTX,NMIDPC,WORK(KIADRS),WORK(KINDST), 1200 & WORK(KINDTM),WORK(KNPRTN),WORK(KIDCMP),WORK(KIEQVG), 1201 & WORK(KICIN),WORK(KIRPID),MBKLIN,NMBKLN,NDERIV,LWRK, 1202 & NDIME,NINTIN,MAXADR,LDPMTX,IFRSTD,MAXINR, 1203 & LTHTST,IDIMAX,IDIMIN,LURSTR,IPRINT,WRKDLM, 1204c#if defined (VAR_MPI) 1205c & WORK(KFTVAL),SYMDET,RSTDON) 1206c#else 1207 & SYMDET,RSTDON) 1208c#endif 1209C 1210C *** Close the restart file *** 1211C 1212 CALL GPCLOSE(LURSTR,'KEEP') 1213C 1214C *** Reevaluate restart parameter *** 1215C 1216 IF (RESTRT.AND.RSTDON) THEN 1217 RESTRT = .FALSE. 1218 END IF 1219C 1220 IF (MYNUM.EQ.0) THEN 1221 LTEXT = 6 1222 PRTEXT(1:6) = 'normal' 1223C 1224 NPRRDR = NAORDR + NMORDR 1225 NDIMT = NDCOOR*(NDCOOR+1)*(NDCOOR+2)/6 1226 NDIMF = NDCOOR*(NDCOOR+1)*(NDCOOR+2)*(NCOOR+3)/24 1227C 1228 KTDRS = 1 1229 KFDRS = KTDRS + NDIMT 1230C 1231 KTTMPD = 2 1232 KFTMPD = KTTMPD + NCOOR**3 1233 KLAST = KFTMPD + NCOOR**4 1234 LWRK = LWORK - KLAST + 1 1235C 1236CRF If we calculate only properties in this run, 1237CRF the derivatives will be from a previous run, and thus shouldn't be printed 1238 IF (.NOT. PRPONL) 1239 & CALL PRDERV(DERIV(KTDRS),DERIV(KFDRS),TSTGDR,TSTSDR,SYMCOR, 1240 & CSTART,WORK(KTTMPD),WORK(KFTMPD),RNNORM,WORK(KLAST), 1241 & ICRIRP,LWRK,NPRRDR,NDIMT,NDIMF,LTEXT,IPRINT,PRTEXT) 1242 1243 1244C 1245C *** Isotope analysis. *** 1246C 1247c KTPGRD = 2 1248c KTPHES = KTPGRD + NCOOR 1249c KTPMSS = KTPHES + NCOOR**2 1250c KTPTD1 = KTPMSS + NCOOR 1251c KTPTD2 = KTPTD1 + NCOOR**3 1252c KLAST = KTPTD2 + NCOOR**3 1253c LWRK = LWORK -KLAST + 1 1254c IF (KLAST.GT.LWORK)CALL QUIT('Memory exceeded in NRMISO') 1255c CALL NRMISO(DERIV(KTDRS),SYMCOR,DKIN,TRNCCR,TRAMSS, 1256c & WORK(KTPGRD),WORK(KTPHES),WORK(KTPMSS), 1257c & WORK(KTPTD1),WORK(KTPTD2),CSTART,WORK(KLAST), 1258c & NDIMT,LWRK) 1259 END IF 1260 END IF 1261C 1262 IF (MYNUM.EQ.0) THEN 1263 IF (NAORDR.EQ.0) THEN 1264 ANDER = 'energy ' 1265 ELSE IF (NAORDR .EQ. 1) THEN 1266 ANDER = 'gradient' 1267 ELSE 1268 ANDER = 'hessian ' 1269 END IF 1270C 1271 IF (DRYRUN) THEN 1272 WRITE (LUPRI,'(//5X,A,I10)') '.DRYRUN: Number of ' // 1273 & ANDER // ' calculations needed:', NUMCAL 1274 ELSE 1275 WRITE (LUPRI,'(//A,I10)') '@Number of ' // ANDER // 1276 & ' calculations done:', NUMCAL 1277 END IF 1278 1279 CALL TITLER('Numerical derivatives have now been calculated.', 1280 & '*',118) 1281 1282C 1283 IF (ANALZ1) THEN 1284 CALL PRIPRP 1285 CALL NVBDRV(DERIV,SYMCOR,FREQ,RNNORM,CSTART,WORK,LWORK, 1286 & NDERIV,IPRINT) 1287 END IF 1288 END IF 1289C 1290 RETURN 1291 END 1292C 1293C /* Deck nmder */ 1294 SUBROUTINE NMDER(DERIV,FUNVAL,COOR,CSTART,SYMCOR,ENTST,DCOEFF, 1295 & GRIREP,CHRCTR,EGRAD,EHESS,WORK,ICRIRP,KDPMTX, 1296 & NMIDPC,IADRSS,INDSTP,INDTMP,NPRTNR,IDCOMP, 1297 & IEQVGM,ICIN,IRPIND,MBKLIN,NMBKLN,NDERIV,LWORK, 1298 & NDIME,NINTIN,MAXADR,LDPMTX,IFRSTD,MAXINR, 1299 & LTHTST,IDIMAX,IDIMIN,LURSTR,IPRINT,WRKDLM, 1300c#if defined (VAR_MPI) 1301c & FTVAL,SYMDET,RSTDON) 1302c#else 1303 & SYMDET,RSTDON) 1304c#endif 1305#include "implicit.h" 1306#include "priunit.h" 1307#include "mxcent.h" 1308#include "maxorb.h" 1309 PARAMETER (D1 = 1.0D0, DM1 = -1.0D0, D0 = 0.0D0, DMAX=1.0D-15) 1310c#if defined (VAR_MPI) 1311c INCLUDE 'mpif.h' 1312c DIMENSION my_STATUS(MPI_STATUS_SIZE) 1313c DIMENSION FTVAL(NINTIN,NDIME) 1314c#endif 1315c#if defined (VAR_MPI2) 1316cC 1317cC pario.h will no longer be needed as an include file when locking RMA 1318cC operations become available. 1319cC 1320c#include "dummy.h" 1321c#include "pario.h" 1322c#endif 1323#include "infpar.h" 1324#include "inforb.h" 1325#include "cbiexc.h" 1326C 1327#include "trkoor.h" 1328#include "nuclei.h" 1329#include "numder.h" 1330#include "molinp.h" 1331#include "cbiwlk.h" 1332#include "cbinum.h" 1333#include "fcsym.h" 1334#include "abainf.h" 1335#include "pvibav.h" 1336#include "prpc.h" 1337#include "gnrinf.h" 1338C 1339 LOGICAL CALCMP, CLNRGY, LASTE, NOSYM, TOTSM, SYMDET, RSTDON, 1340 & ALRCAL, PRTNR, CPRPBK 1341 CHARACTER*(len_MLINE) MBKLIN(NMBKLN), MLINE_in_upcase 1342 DIMENSION FUNVAL(NINTIN,NDIME), COOR(NCOOR), CSTART(NCOOR), 1343 & DERIV(NDERIV), DCOEFF(LDPMTX,IFRSTD), 1344 & SYMCOR(NCOOR,NCOOR), GRIREP(NGORDR,NGVERT), 1345 & CHRCTR(NGORDR,NCVERT), EGRAD(MXCOOR), 1346 & EHESS(MXCOOR,MXCOOR), ENTST(LTHTST), WORK(LWORK) 1347 DIMENSION INDSTP(NTORDR), INDTMP(NTORDR), ICIN(NMORDR), 1348 & IDCOMP(NCOOR), IADRSS(MAXADR), IRPIND(NMORDR), 1349 & ICRIRP(NCOOR,2), KDPMTX(LDPMTX,NSTRDR,IFRSTD), 1350 & NMIDPC(LDPMTX), IEQVGM(NMORDR,2), NPRTNR(MAXINR) 1351C 1352 CALL QENTER('NMDER') 1353c#if defined (VAR_MPI2) 1354c LUNMCL = -9056 1355c#endif 1356C 1357C *** Numerical derivatives general header. *** 1358C 1359 CALL TITLER('@ Numerical derivatives.','*',118) 1360 CALL HEADER('@ Derivatives calculated:',0) 1361 WRITE (LUPRI,'(A,I3)') 1362 & '@ Derivatives calculated to order', NMORDR + NAORDR 1363 WRITE (LUPRI,'(A,I3,A)') 1364 & '@ Analytical derivatives from energies to ', 1365 & NAORDR, ' order.' 1366 WRITE (LUPRI,'(A,I3,A,I3,A)') 1367 & '@ ', NMORDR, '. numerical derivatives from',NAORDR, 1368 & '. order analytical derivatives' 1369C 1370C *** Symmetry adapted coordinates *** 1371C 1372 IF (SYMDET) THEN 1373 CALL GRPCHR(CSTART,SYMCOR,GRIREP,CHRCTR,WORK,ICRIRP,LWORK, 1374 & IPRINT) 1375 SYMDET = .FALSE. 1376 END IF 1377C 1378C *** Finding force constants that are dependent on each-other *** 1379C 1380 NLDPMX = 0 1381 KDIM = IFRSTD*NSTRDR*LDPMTX 1382 CALL IZERO(KDPMTX,KDIM) 1383 CALL FSDCST(SYMCOR,GRIREP,DCOEFF,WORK,KDPMTX,NMIDPC,ICRIRP,LDPMTX, 1384 & IFRSTD,NLDPMX,LWORK,IPRINT) 1385C 1386C *** Memory allocations for future use *** 1387C 1388 NTYPE = 3 1389 LASTE = .FALSE. 1390 NOSYM = .FALSE. 1391 MLINE_in_upcase = MLINE(NMLINE_4) 1392 CALL UPCASE(MLINE_in_upcase) 1393 IPOS = INDEX(MLINE_in_upcase,'ATO') 1394 IF (IPOS .EQ. 0) THEN 1395 IF (MLINE_in_upcase(10:10).EQ.'0') NOSYM = .TRUE. 1396 ELSE 1397 IPOS = INDEX(MLINE_in_upcase,'NOS') 1398 IF (IPOS .NE. 0) NOSYM = .TRUE. 1399 END IF 1400C 1401 KIDTMP = 1 1402 KIRPDG = KIDTMP + NMORDR 1403 KIRPST = KIRPDG + NMORDR 1404C 1405 ITYPE = 1 1406C 1407 IDIME = 2 1408 IF (PGMTST) EMAX = D0 1409C 1410C *** Order for derivatives *** 1411C 1412 DO 100 IORDR = 1, NMORDR 1413 IHORDR = INT((IORDR+1)/2) 1414C 1415C *** IHORDR -> The maximum order in one direction for this *** 1416C *** numerical derivative. *** 1417C 1418 DO 200 IMXRDR = 1, IHORDR, 1 1419C 1420 ITYPE = ITYPE + 1 1421 IADRSS(ITYPE) = IDIME - 1 1422C 1423C *** The first component IX1 has always the largest order, *** 1424C *** and are then independent of the others *** 1425C *** The order of the other components are not larger than one *** 1426C 1427 IMINCR = 1 1428 IF (IMXRDR .EQ. 1) IMINCR = IORDR 1429 IRSRDR = IORDR - (2*IMXRDR-1) 1430 DO 300 IX1 = IMINCR, NDCOOR 1431C 1432C *** Starting values for the component-vector. *** 1433C 1434 INDSTP(1) = IX1 1435 DO 400 IC = IRSRDR+1, 2, -1 1436 INDSTP(IC) = IRSRDR+2-IC 1437 400 CONTINUE 1438 IF (IRSRDR .GT. 0) INDSTP(IRSRDR+1) = INDSTP(IRSRDR+1)-1 1439C 1440 NSTP = 1 1441 IF (IMXRDR .EQ. 1) THEN 1442 DO 500 I = 1, IRSRDR 1443 NSTP = NSTP*(IX1-I)/I 1444 500 CONTINUE 1445 ELSE 1446 DO 600 I = 1, IRSRDR 1447 NSTP = NSTP*(NDCOOR-I+1)/I 1448 600 CONTINUE 1449 END IF 1450C 1451C *** NSTP -> Number of components for this IORDR, IMXRDR and IX1*** 1452C 1453 DO 700 ISTP = 1, NSTP 1454C 1455C *** Finding the other components. *** 1456C 1457 CALCMP = .TRUE. 1458 IF (IMXRDR .EQ. 1) THEN 1459 DO 800 IC = IRSRDR+1, 2, -1 1460 IF (INDSTP(IC) .LT. (INDSTP(IC-1)-1)) THEN 1461 INDSTP(IC) = INDSTP(IC) + 1 1462 DO 900 I = IC+1, IRSRDR+1 1463 INDSTP(I) = (IRSRDR+2) - I 1464 900 CONTINUE 1465 GOTO 1300 1466 END IF 1467 800 CONTINUE 1468 ELSE 1469 DO 1000 IC = IRSRDR+1, 2, -1 1470 IF (IC .EQ. 2) THEN 1471 INDSTP(2) = INDSTP(2) + 1 1472 DO 1100 I = 3, IRSRDR+1 1473 INDSTP(I) = 1 1474 1100 CONTINUE 1475 DO 1150 ICN = 2, IRSRDR+1 1476 IF (INDSTP(ICN) .EQ. IX1) CALCMP = .FALSE. 1477 1150 CONTINUE 1478 GOTO 1300 1479 ELSE IF (INDSTP(IC) .LT. (INDSTP(IC-1)-1)) THEN 1480 INDSTP(IC) = INDSTP(IC) + 1 1481 DO 1200 I = IC+1, IRSRDR 1482 INDSTP(I) = 1 1483 1200 CONTINUE 1484 DO 1250 ICN = 2, IRSRDR+1 1485 IF (INDSTP(ICN) .EQ. IX1) CALCMP = .FALSE. 1486 1250 CONTINUE 1487 GOTO 1300 1488 END IF 1489 1000 CONTINUE 1490 END IF 1491C 1492 1300 CONTINUE 1493C 1494C *** Have we calculated this function-value before? *** 1495C 1496 IF (CALCMP) THEN 1497C 1498C *** IDCOMP(INDSTP(IC)) -> gives the length of the *** 1499C *** steps we need to do in INDSTP(IC) direction. *** 1500C 1501 CALL IZERO(IDCOMP,NDCOOR) 1502 IDCOMP(INDSTP(1)) = IMXRDR 1503 DO 1400 IC = 2, IRSRDR+1 1504 IDCOMP(INDSTP(IC)) = IDCOMP(INDSTP(IC)) + 1 1505 1400 CONTINUE 1506C 1507C *** NINNER -> Number of different steps needed *** 1508C *** If numerical derivatives from energy is *** 1509C *** calculated, we need to check whether the *** 1510C *** steps are all totally symmetric. *** 1511C 1512 IF (NAORDR .EQ. 0) THEN 1513 IJ = 1 1514 TOTSM = .FALSE. 1515 DO IRDR = 1, IRSRDR+1 1516 IJ = IJ*ICRIRP(INDSTP(IRDR),1) 1517 END DO 1518 IF (IJ.EQ.1) TOTSM = .TRUE. 1519 END IF 1520C 1521 NINNER = 2**(IRSRDR+1) 1522C 1523 NMPRTN = 0 1524 CALL IZERO(NPRTNR,MAXINR) 1525C 1526 DO 1500 IINNER = 1, NINNER 1527C 1528C *** Initialize alrcal. *** 1529C 1530 ALRCAL = .FALSE. 1531C 1532C *** Finding the appropriate step-possibility. *** 1533C 1534 IC = 0 1535 IDIV = 1 1536 DO 1600 I = 1, IRSRDR+1 1537 I_MOD = MOD(INT((IINNER-1)/IDIV),2) 1538 IF (I_MOD .EQ. 0) THEN 1539 ICIN(I) = 1 1540 ELSE 1541 ICIN(I) = -1 1542 END IF 1543 IDIV = IDIV*2 1544 1600 CONTINUE 1545C 1546C *** Making the appropriate step, and *** 1547C *** get the function value. *** 1548C 1549 CALL GTNPNT(FUNVAL,GRIREP,SYMCOR,EGRAD,EHESS, 1550 & COOR,CSTART,WORK,WRKDLM,INDSTP,ICRIRP, 1551 & NPRTNR,ICIN,KDPMTX,IRPIND,IDCOMP,LDPMTX, 1552 & IFRSTD,NLDPMX,IORDR,IRSRDR,IINNER,NMPRTN, 1553 & NDIME,MAXINR,LWORK,NMBKLN,MBKLIN,IDIME, 1554 & NINTIN,IDIMAX,IDIMIN,LURSTR, 1555c#if defined (VAR_MPI) 1556c & FTVAL,RSTDON,PRTNR,ALRCAL,CLNRGY,LASTE) 1557c#else 1558 & RSTDON,PRTNR,ALRCAL,CLNRGY,LASTE) 1559c#endif 1560C 1561 1500 CONTINUE 1562 IDIME = IDIME + NMPRTN 1563 END IF 1564 700 CONTINUE 1565C 1566 300 CONTINUE 1567 200 CONTINUE 1568 100 CONTINUE 1569C 1570C *** Returning to the original geometry, only for master. *** 1571C 1572 IF (MYNUM .EQ. 0) THEN 1573 1574! reset molden.inp file after finished all modified geometries for numerical derivatives 1575! (this will also use .P-BASIS for molden.inp if .P-BASIS specified). 1576 CALL MOLDEN_HEAD 1577 1578 IORDR = 0 1579 IDIME = 1 1580 CLNRGY = .TRUE. 1581 MINLIM = 1 1582 IADRSS(1) = 0 1583 LASTE = .TRUE. 1584 IF (NAORDR.EQ.1) MINLIM = NCOOR 1585 CALL GTNPNT(FUNVAL,GRIREP,SYMCOR,EGRAD,EHESS,COOR,CSTART,WORK, 1586 & WRKDLM,INDSTP,ICRIRP,NPRTNR,ICIN,KDPMTX,IRPIND,IDCOMP, 1587 & LDPMTX,IFRSTD,NLDPMX,0,IRSRDR,IINNER,NMPRTN,NDIME, 1588 & MAXINR,LWORK,NMBKLN,MBKLIN,IDIME,NINTIN,IDIMAX,IDIMIN, 1589c#if defined (VAR_MPI) 1590c & LURSTR,FTVAL,RSTDON,PRTNR,ALRCAL,CLNRGY,LASTE) 1591c#else 1592 & LURSTR,RSTDON,PRTNR,ALRCAL,CLNRGY,LASTE) 1593c#endif 1594C 1595c#if defined (VAR_MPI) 1596c ELSE 1597c DO IDIME = 1, NDIME 1598c DO INTIN = 1, NINTIN 1599c FUNVAL(INTIN,IDIME) = D0 1600c END DO 1601c END DO 1602c#endif 1603 END IF 1604C 1605c#if defined (VAR_MPI) 1606cC 1607cC *** If parallel calculation all energies are *** 1608cC *** collected into one array. *** 1609cC 1610c#if defined (VAR_MPI2) 1611cC 1612cC However, in the case of "simulated" MPI2 behaviour (RMA operations), 1613cC there can occur a "glitch" in the NFS lock file, and points may happen 1614cC to be calculated on several processors. 1615cC 1616cC We collect results from one processor at a time, checking for double 1617cC counting 1618cC 1619c IF (MYNUM .EQ. 0) THEN 1620c CALL DCOPY(NDIME,FTVAL,1,FUNVAL,1) 1621c DO IWHO = 1, NODTOT 1622c CALL MPI_RECV(NWHO,1,my_MPI_INTEGER,MPI_ANY_SOURCE,65, 1623c & MPI_COMM_WORLD,ISTAT,IERR) 1624c CALL MPI_RECV(FTVAL,NDIME,MPI_DOUBLE_PRECISION,NWHO,65, 1625c & MPI_COMM_WORLD,ISTAT,IERR) 1626c DO IPOS = 1, NDIME 1627cC 1628cC Molecular energies ought to be negative 1629cC 1630c IF (.NOT. (FUNVAL(IPOS) .LT. D0)) 1631c & FUNVAL(IPOS) = FTVAL(IPOS) 1632c END DO 1633c END DO 1634c ELSE 1635c CALL MPI_SEND(MYNUM,1,my_MPI_INTEGER,MASTER, 1636c & 65,MPI_COMM_WORLD,IERR) 1637c CALL MPI_SEND(FTVAL,NDIME,MPI_DOUBLE_PRECISION,MASTER, 1638c & 65,MPI_COMM_WORLD,IERR) 1639c END IF 1640c#else 1641c CALL MPI_REDUCE(FTVAL,FUNVAL,NINTIN*NDIME,MPI_DOUBLE_PRECISION, 1642c & MPI_SUM,0,MPI_COMM_WORLD,IERR) 1643c#endif 1644c#endif 1645C 1646 IF (MYNUM.EQ.0) THEN 1647C 1648C ******************************************** 1649C *** Preliminary constants to derivatives *** 1650C ******************************************** 1651CRF To posibly allow NMRDRP .le. NMORDR 1652 MXCOEF = INT(MAX(NMORDR,NMRDRP)/2) + 1 1653C 1654C **************************************************** 1655C *** Calculating force field. Property derivative *** 1656C *** needs to be reset for call for NMNDER. *** 1657C **************************************************** 1658C 1659 CPRPBK = CNMPRP 1660 CNMPRP = .FALSE. 1661C 1662C *********************************** 1663C *** Calculating the derivatives *** 1664C *********************************** 1665C 1666CRF 16/11 We skip calculating new geometrical derivatives 1667CRF if only property derivatives are calculated this run 1668 IF ( .NOT. PRPONL) THEN 1669 NFINNR = 1 1670 KCOEF = 1 1671 KIMAX = KCOEF + (2*MXCOEF+1)*(NMORDR+1) 1672 KIMIN = KIMAX + NMORDR 1673 KICNT = KIMIN + NMORDR 1674 KNCVAL = KICNT + NTYPE 1675 KIDDCP = KNCVAL + NCOOR 1676 KLAST = KIDDCP + NCOOR 1677 LWRK1 = LWORK - KLAST 1678 IF (LWRK1.LT.1) CALL QUIT('Memory exceeded in NMNDER') 1679 CALL NMNDER(DERIV,WORK(KCOEF),FUNVAL,GRIREP,WORK(KLAST), 1680 & IADRSS,KDPMTX,ICRIRP,INDSTP,INDTMP,IDCOMP,WORK(KIMAX), 1681 & WORK(KIMIN),WORK(KICNT),WORK(KNCVAL),WORK(KIDDCP), 1682 & MXCOEF,NMORDR,NDIME,NTYPE,NDERIV,NINTIN,LDPMTX,IFRSTD, 1683 & NLDPMX,LWRK1,.TRUE.) 1684 END IF 1685CRFend 1686C 1687C ************************************** 1688C *** Resetting property derivative. *** 1689C ************************************** 1690C 1691 CNMPRP = CPRPBK 1692C 1693C ********************************************************** 1694C *** Assigning values to the dependent force constants. *** 1695C ********************************************************** 1696C 1697 IF (NAORDR.EQ.0) THEN 1698 CALL ADDPFC(DERIV,DCOEFF,KDPMTX,NMIDPC,LDPMTX,IFRSTD, 1699 & NDERIV,NLDPMX,IPRINT) 1700 END IF 1701C 1702C ***************************************** 1703C *** Calculating property derivatives. *** 1704C ***************************************** 1705C 1706 IF ((NPRPDR).AND.((.NOT.NRMCRD).OR. 1707 & (NRMCRD.AND..NOT.FRSTNM))) THEN 1708C 1709C *** Workaround to avoid common commonblock *** 1710C *** variables. *** 1711C 1712 CALL STPPVR 1713C 1714 KCOEF = 1 1715CRF Is this an error, second dimension of argument 3 COEFF is 1716C 0:NMRDRP in PRPDER, not 0:NMORDR as this surgests 1717C KIMAX = KCOEF + (2*MXCOEF+1)*(NMORDR+1) 1718 KIMAX = KCOEF + (2*MXCOEF+1)*(NMRDRP+1) 1719CRFend 1720 KIMIN = KIMAX + NMRDRP 1721 KICNT = KIMIN + NMRDRP 1722 KNCVAL = KICNT + NTYPE 1723 KIDDCP = KNCVAL + NCOOR 1724 KLAST = KIDDCP + NCOOR 1725 NPPDER = NDCOOR 1726 IF (NMRDRP.GE.2) NPPDER = NPPDER + NDCOOR*(NDCOOR+1)/2 1727 IF (NMRDRP.GE.3) NPPDER = NPPDER 1728 & + NDCOOR*(NDCOOR+1)*(NDCOOR+2)/6 1729 IF (NMRDRP.GE.4) NPPDER = NPPDER 1730 & + NDCOOR*(NDCOOR+1)*(NDCOOR+2)*(NDCOOR+3)/24 1731C 1732C 1733 IF (DOCCSD) THEN 1734C 1735C *** Derivatives of cc-properties. *** 1736C 1737 KCCPRP = KLAST 1738 KDCCPR = KCCPRP + NMPCAL*NPRPC 1739 KLAST = KDCCPR + NPPDER*NPRPC 1740 ELSE 1741 IF (SPNSPN) THEN 1742 KSPNSP = KLAST 1743 KDSPSP = KSPNSP + 6*NMPCAL*NCOOR**2 1744 KLAST = KDSPSP + 6*NPPDER*NCOOR**2 1745 END IF 1746 IF (DODIPS) THEN 1747 KTRLEN = KLAST 1748 KDRTRL = KTRLEN + 3*NMPCAL*NSYM*MXNEXI 1749 KEXEFV = KDRTRL + 3*NPPDER*NSYM*MXNEXI 1750 KLAST = KEXEFV + NMPCAL*NSYM*MXNEXI 1751 END IF 1752 END IF 1753C 1754 LWRK1 = LWORK - KLAST 1755 IF (LWRK1.LT.1) CALL QUIT('Memory exceeded in PRPDER') 1756 CALL PRPDER(SYMCOR,WORK(KDSPSP),WORK(KCOEF),WORK(KSPNSP), 1757 & WORK(KTRLEN),WORK(KDRTRL),WORK(KEXEFV),WORK(KCCPRP), 1758 & WORK(KDCCPR),GRIREP,WORK(KLAST),IADRSS,KDPMTX, 1759 & ICRIRP,INDSTP,IDCOMP,WORK(KIMAX),WORK(KIMIN), 1760 & WORK(KICNT),WORK(KNCVAL),WORK(KIDDCP),MXCOEF,NTYPE, 1761 & NPPDER,LDPMTX,IFRSTD,NLDPMX,MXNEXI,NSYM,LWRK1, 1762 & IPRINT) 1763 END IF 1764C 1765C ******************* 1766C *** Test print. *** 1767C ******************* 1768C 1769 IF (PGMTST) THEN 1770 WRITE (LUPRI,'(A)') ' ' 1771 WRITE (LUPRI,'(A)') 1772 & 'Test "equal energy for partner geometries" is complete.' 1773 WRITE (LUPRI,'(A,F20.12)') 'Maximum error in energy is:', 1774 & EMAX 1775 WRITE (LUPRI,'(A,F20.12)') 'Relative error: ' 1776 DO IRDR = 1, NMORDR 1777 WRITE (LUPRI,'(I2,A,F14.8)') IRDR, '. derivative: ', 1778 & EMAX/(DISPLC**(DBLE(IRDR))) 1779 END DO 1780 END IF 1781 END IF 1782C 1783 CALL QEXIT('NMDER') 1784 RETURN 1785 END 1786C 1787C /* Deck gtnpnt */ 1788 SUBROUTINE GTNPNT(FUNVAL,GRIREP,SYMCOR,EGRAD,EHESS,COOR,CSTART, 1789 & WORK,WRKDLM,INDSTP,ICRIRP,NPRTNR,ICIN,KDPMTX, 1790 & IRPIND,IDCOMP,LDPMTX,IFRSTD,NLDPMX,IORDR,IRSRDR, 1791 & IINNER,NMPRTN,NDIME,MAXINR,LWORK,NMBKLN,MBKLIN, 1792 & IDIME,NINTIN,IDIMAX,IDIMIN,LURSTR, 1793c#if defined (VAR_MPI) 1794c & FTVAL,RSTDON,PRTNR,ALRCAL,CLNRGY,LASTE) 1795c#else 1796 & RSTDON,PRTNR,ALRCAL,CLNRGY,LASTE) 1797c#endif 1798C 1799C Purpose: Get next geometry point for mumerical differentiation 1800C 1801#include "implicit.h" 1802#include "priunit.h" 1803#include "maxorb.h" 1804#include "mxcent.h" 1805 PARAMETER (D0=0.0D0) 1806c#if defined (VAR_MPI) 1807c INCLUDE 'mpif.h' 1808c DIMENSION FTVAL(NINTIN,NDIME) 1809c#endif 1810c#if defined (VAR_MPI2) 1811cC 1812cC pario.h will no longer be needed as an include file when locking RMA 1813cC operations become available. 1814cC 1815c#include "dummy.h" 1816c#include "pario.h" 1817c#endif 1818#include "abainf.h" 1819#include "cbinum.h" 1820#include "cbiwlk.h" 1821#include "optinf.h" 1822#include "trkoor.h" 1823#include "infpar.h" 1824#include "numder.h" 1825#include "fcsym.h" 1826#include "moldip.h" 1827#include "past.h" 1828#include "pvibav.h" 1829#include "gnrinf.h" 1830#include "nuclei.h" 1831c 1832#include "huckel.h" 1833 LOGICAL RUNPNT, CLNRGY, RSTDON, PRTNR, EXSIR, EXHER, EXABA, EXESG, 1834 & ALRCAL, PRPCAL, FNDKEY, NOMOVE_bkp 1835 LOGICAL LASTE 1836 CHARACTER*(*) MBKLIN 1837 DIMENSION MBKLIN(NMBKLN) 1838 DIMENSION FUNVAL(NINTIN,NDIME), COOR (NCOOR), SYMCOR(NCOOR,NCOOR), 1839 & CSTART(NCOOR), EGRAD(MXCOOR), EHESS(MXCOOR,MXCOOR), 1840 & GRIREP(NGORDR,NGVERT), WORK(LWORK) 1841 DIMENSION INDSTP(NTORDR), ICRIRP(NCOOR,2), NPRTNR(MAXINR), 1842 & ICIN(NMORDR), KDPMTX(LDPMTX,NSTRDR,IFRSTD), 1843 & IRPIND(NMORDR), IDCOMP(NCOOR) 1844C 1845 CALL QENTER('GTNPNT') 1846 1847 NOMOVE_bkp = NOMOVE 1848 NOMOVE = .TRUE. ! do not change molecular coordinates when numerical differentiation 1849C 1850C *** Symmetry initilization. *** 1851C 1852 PRTNR = .FALSE. 1853C 1854 KDIM = 3*NCOOR 1855 CALL DCOPY(KDIM,CSTART,1,COOR,1) 1856C 1857C *** If property derivatives are calculated at this *** 1858C *** geometry, som variables needs to be set. *** 1859C 1860 IF ((.NOT.NRMCRD).OR.(NRMCRD.AND..NOT.FRSTNM)) THEN 1861 IF ((PRPVIB).AND.(IORDR.LE.1)) THEN 1862 NMPCAL = NMPCAL + 1 1863 CNMPRP = .TRUE. 1864 ELSE IF ((.NOT.PRPVIB).AND.(IORDR.LE.NMRDRP) 1865 & .AND.(NMRDRP.GT.0)) THEN 1866 NMPCAL = NMPCAL + 1 1867 CNMPRP = .TRUE. 1868 ELSE 1869 CNMPRP = .FALSE. 1870 END IF 1871 END IF 1872CRF A crude way of avoiding redudant calculations 1873 IF (PRPONL .AND. .NOT. CNMPRP) THEN 1874 GO TO 9000 1875 END IF 1876C 1877C *** Making the appropriate step, if any. *** 1878C 1879 IF (IDIME.NE.1) THEN 1880 DO 1700 IC = 1, IRSRDR+1 1881 DO 1700 IMXN = 1, IDCOMP(INDSTP(IC)) 1882 CALL STPCOR(COOR,COOR,SYMCOR,DISPLC,NCOOR,ICIN(IC), 1883 & INDSTP(IC),IPRINT) 1884 1700 CONTINUE 1885C 1886C *** Symmetry of derivatives calculated *** 1887C 1888 CLNRGY = .FALSE. 1889 KIDTMP = 1 1890 KIDDBT = KIDTMP + NMORDR 1891 KIRPDG = KIDDBT + NMORDR 1892 KIRPST = KIRPDG + NMORDR 1893 KLAST = KIRPST + NMORDR 1894 LWRK = LWORK - KLAST + 1 1895 CALL FCSCRN(GRIREP,WORK(KLAST),KDPMTX,INDSTP,ICRIRP,IRPIND, 1896 & WORK(KIDTMP),WORK(KIDDBT),WORK(KIRPDG), 1897 & WORK(KIRPST),NPRTNR,LWRK,NLDPMX,LDPMTX,IFRSTD, 1898 & IORDR,IRSRDR,MAXINR,IINNER,NMPRTN,IPRINT,CLNRGY, 1899 & PRTNR,ALRCAL,.FALSE.) 1900C 1901C *** Test print. *** 1902 IF (IPRINT.GT.10) THEN 1903 WRITE (LUPRI,'(A, 12I5)') 'Component: ', 1904 & (ICIN(I)*INDSTP(I),I=1,IRSRDR+1) 1905 END IF 1906 END IF 1907C 1908C *** Information needed for .MANUAL keyword. *** 1909C 1910 IF (MANUAL) THEN 1911 WRITE (LUPRI,'(/5X,A,I5)') 'Manual geometry calculated', IDIME 1912 IF (PRTNR) THEN 1913 WRITE (LUPRI,'(5X,A,I5)') 'Partner geometry', 1914 & IDIME - IINNER + NPRTNR(NMPRTN) 1915 END IF 1916 END IF 1917C 1918C *** Calculate the energy, gradient or hessian. If *** 1919C *** this is a parallel job, we need to find the *** 1920C *** proper processor. *** 1921C 1922 IF (RUNPNT(CLNRGY,IRSRDR+1,IDIME)) THEN 1923C 1924C *** Another calculation. *** 1925C 1926 NUMCAL = NUMCAL + 1 1927C 1928c#if defined (VAR_MPI) 1929c#if defined (VAR_MPI2) 1930cC 1931cC The following code should be replaced with RMA operations following 1932cC the MPI-2 standard and as exemplified in for example Fig.6-9 in 1933cC "Using MPI-2" by Gropp, Lusk, and Thakur, and WIN_LOCK becomes 1934cC available in an MPI-2 implementation 1935cC 1936c 199 CONTINUE 1937c OPEN(UNIT=99,FILE=WRKDIR(1:LENWRK)//'LOCK',STATUS='NEW', 1938c & FORM='FORMATTED',ERR=199) 1939c CALL GPOPEN(LUNMCL,WRKDIR(1:LENWRK)//'NUMCAL','OLD',' ', 1940c & 'FORMATTED',IDUMMY,.FALSE.) 1941c READ (LUNMCL,'(I5)') NUMCL 1942c IF (NUMCL .EQ. NUMCAL) THEN 1943c REWIND (LUNMCL) 1944c WRITE (LUNMCL,'(I5)') NUMCL + 1 1945c CALL GPCLOSE(LUNMCL,'KEEP') 1946c CLOSE(UNIT=99,STATUS='DELETE',ERR=107) 1947c 107 CONTINUE 1948c#else 1949c IF (MYNUM.EQ.MOD(NUMCAL,(NODTOT+1))) THEN 1950c#endif 1951c#endif 1952C 1953C *** Header print *** 1954C 1955 CALL HEADER('@ Next numerical derivative component',0) 1956 IF (IDIME.NE.1) THEN 1957 WRITE (LUPRI,'(A,(T6,12I5))') '@ ', 1958 & (ICIN(I)*INDSTP(I),I=1,IRSRDR+1) 1959 ELSE 1960 WRITE (LUPRI,'(A)') '@ Starting geometry.' 1961 END IF 1962C 1963 IF ((.NOT.DRYRUN).AND.((.NOT.RESTRT).OR.(RESTRT.AND.RSTDON 1964 & .AND.((IDIME.GT.IDIMAX).OR.(IDIME.LT.IDIMIN))))) THEN 1965C 1966C *** Reducing symmetry in the DALTON.INP file. *** 1967C 1968c CALL DALCHG(INDSTP,ICRIRP,IRSRDR,IPRINT,NCOOR,NMORDR, 1969c & .FALSE.) 1970C 1971C *** Update MOLECULE.INP file and molinp.h common block *** 1972C 1973 CALL UPD_MOLINP(COOR,MBKLIN,NMBKLN,LASTE) 1974C 1975C *** Reset necessary variables *** 1976C 1977 CALL NDER_RESET(EXHER,EXSIR,EXABA) 1978cdj 1979 EXESG = FNDKEY('*ESG ') 1980C 1981C *** Find the energy, gradient or hessian *** 1982C 1983 IF (NAORDR .EQ. 0) THEN 1984 CALL GTNRGY(EXHER,EXSIR,EXABA,EXESG, 1985 $ WORK,LWORK,WRKDLM) 1986c#if defined (VAR_MPI) 1987c FTVAL(1,IDIME) = ENERGY 1988c#else 1989 FUNVAL(1,IDIME) = ENERGY 1990c#endif 1991 WRITE(LURSTR,'(2I8,F24.16)') 1, IDIME, ENERGY 1992 IF (PRTNR) THEN 1993 IMDIME = IDIME - IINNER + NPRTNR(NMPRTN) 1994 FUNVAL(1,IMDIME) = ENERGY 1995 WRITE(LURSTR,'(2I8,F24.16)') 1, IMDIME, ENERGY 1996 END IF 1997 CALL FLSHFO(LURSTR) 1998C 1999 IDIME = IDIME + 1 2000C 2001C **************************************************** 2002C *** If derivatives of properties are calculated. *** 2003C **************************************************** 2004C 2005 IF (CNMPRP) THEN 2006C 2007C ************************************************ 2008C *** Calculating properties for this geometry *** 2009C ************************************************ 2010C 2011 PASEXC = .FALSE. 2012 DOWALK = .FALSE. 2013 WRINDX = .TRUE. 2014 LUSUPM = -1 2015 WORK(1) = WRKDLM 2016CRF 9/11-12 Should be **EACH to be consistent with NAORDR > 0 2017CRF CALL ABAINP('**PROPE',WORK(2),LWORK) 2018 CALL ABAINP('**EACH ',WORK(2),LWORK) 2019CRFend 2020 CALL EXEABA(WORK(1),LWORK-1,WRKDLM) 2021C 2022 KTRAMT = 1 2023 KCRTPR = KTRAMT + NCOOR**2 2024 CALL TRMTOC(WORK(KTRAMT),COOR,WORK(KCRTPR),NCOOR, 2025 & IPRINT) 2026 END IF 2027C 2028 ELSE IF (NAORDR .EQ. 1) THEN 2029C ****************************************************** 2030C *** If gradient is used, property calculations are *** 2031C *** run through GTGRAD. *** 2032C ****************************************************** 2033C 2034 CALL GTGRAD(EGRAD,EXHER,EXSIR,EXABA,WORK,LWORK, 2035 & WRKDLM) 2036C 2037 KSEGRD = 1 2038 KLAST = KSEGRD + NCOOR 2039 LWRK1 = LWORK - KLAST + 1 2040 IF (KLAST.GT.LWORK) 2041 & CALL QUIT('Memory exceeded in TRFCGD') 2042 CALL TRFCGD(EGRAD,SYMCOR,COOR,WORK(KSEGRD), 2043 & WORK(KLAST),NCOOR,NDCOOR,LWRK1,IPRINT) 2044C 2045 ! for numerical molecular Hessian: 2046 DO ICOOR = 1, NDCOOR 2047c#if defined (VAR_MPI) 2048c FTVAL(ICOOR,IDIME) = EGRAD(ICOOR) 2049c#else 2050 FUNVAL(ICOOR,IDIME) = EGRAD(ICOOR) 2051c#endif 2052 WRITE(LURSTR,'(2I8,F24.16)') ICOOR, IDIME, 2053 & EGRAD(ICOOR) 2054 END DO 2055 ! for numerical dipole gradient: 2056 FUNVAL(NCOOR+1,IDIME) = DIP0(1) 2057 FUNVAL(NCOOR+2,IDIME) = DIP0(2) 2058 FUNVAL(NCOOR+3,IDIME) = DIP0(3) 2059 IDIME = IDIME + 1 2060 CALL FLSHFO(LURSTR) 2061 ELSE IF (NAORDR .EQ. 2) THEN 2062C ****************************************************** 2063C *** If hessian is used, property calculations are *** 2064C *** run through GTHESS. *** 2065C ****************************************************** 2066C 2067 KAHESS = 1 2068 KLAST = KAHESS + NCOOR**2 2069 LWRK = LWORK - KLAST +1 2070 CALL GTHESS(EGRAD,EHESS,WORK(KAHESS),EXHER,EXSIR, 2071 & EXABA,WORK(KLAST),LWRK,WRKDLM) 2072C 2073 KSEHSS = 1 2074 KLAST = KSEHSS + NCOOR**2 2075 LWRK1 = LWORK - KLAST + 1 2076 IF (KLAST.GT.LWORK) 2077 & CALL QUIT('Memory exceeded in TRFCHS') 2078 CALL TRFCHS(EHESS,SYMCOR,COOR,WORK(KSEHSS), 2079 & WORK(KLAST),NCOOR,NDCOOR,LWRK1,IPRINT) 2080C 2081 ICOOR12 = 0 2082 DO ICOOR2 = 1, NDCOOR 2083 DO ICOOR1 = 1, ICOOR2 2084 ICOOR12 = ICOOR12 + 1 2085c#if defined (VAR_MPI) 2086c FTVAL(ICOOR12,IDIME) = EHESS(ICOOR1,ICOOR2) 2087c#else 2088 FUNVAL(ICOOR12,IDIME) = EHESS(ICOOR1,ICOOR2) 2089c#endif 2090 WRITE(LURSTR,'(2I8,F24.16)') ICOOR12, IDIME, 2091 & EHESS(ICOOR1,ICOOR2) 2092 END DO 2093 END DO 2094 IDIME = IDIME + 1 2095 CALL FLSHFO(LURSTR) 2096 END IF 2097 ELSE 2098 IDIME = IDIME + 1 2099 END IF 2100c#if defined (VAR_MPI) 2101c ELSE 2102c#if defined (VAR_MPI2) 2103c CALL GPCLOSE(LUNMCL,'KEEP') 2104c CLOSE(UNIT=99,STATUS='DELETE',ERR=108) 2105c 108 CONTINUE 2106c#endif 2107c DO INTIN = 1, NINTIN 2108c FUNVAL(INTIN,IDIME) = D0 2109c END DO 2110c IDIME = IDIME + 1 2111c END IF 2112c#endif 2113 ELSE IF (.NOT.ALRCAL) THEN 2114 IF ((.NOT.RESTRT).OR.(RESTRT.AND. 2115 & RSTDON.AND.(IDIME.GT.IDIMAX))) THEN 2116 DO 2100 INTIN = 1, NINTIN 2117 FUNVAL(INTIN,IDIME) = D0 2118 WRITE(LURSTR,'(2I8,F24.16)') INTIN, IDIME, D0 2119 2100 CONTINUE 2120 CALL FLSHFO(LURSTR) 2121 END IF 2122 IDIME = IDIME + 1 2123 END IF 2124C 2125 9000 CONTINUE 2126 NOMOVE = NOMOVE_bkp 2127 CALL QEXIT('GTNPNT') 2128 RETURN 2129 END 2130C 2131C /* Deck upd_molinp */ 2132 SUBROUTINE UPD_MOLINP(COOR,MBKLIN,NMBKLN,LASTE) 2133C 2134C Update MOLECULE.INP file and molinp.h commonb block. 2135C 2136#include "implicit.h" 2137#include "priunit.h" 2138#include "mxcent.h" 2139#include "maxaqn.h" 2140#include "maxorb.h" 2141C 2142 PARAMETER (D100 = 100.0D0, THRSH = 1.0D-12) 2143#include "cbirea.h" 2144#include "molinp.h" 2145#include "nuclei.h" 2146#include "trkoor.h" 2147#include "symmet.h" 2148#include "numder.h" 2149#include "inftap.h" 2150 LOGICAL BIG, USED, LASTE, DOCART, DOOWN, AUTOSY, NOSYM, ADDSYM, 2151 & NEWINP, NEWATO 2152 CHARACTER*6 CHR 2153 CHARACTER*4 NAME 2154 CHARACTER*(len_MLINE) MBKLIN(NMBKLN), MLINE_in_upcase 2155 CHARACTER*80 BSNM 2156 CHARACTER*11 TMPTXT 2157 CHARACTER*1 KASYM(3,3), ID3, CRT 2158 REAL*8 COOR(3,NCOOR/3) 2159 INTEGER JCO1(MXAQN) 2160 2161C 2162C Updates geometry in common block 2163C 2164 IF (LASTE) THEN 2165 NMLINE = NMBKLN 2166 DO 100 IBKLIN = 1, NMBKLN 2167 MLINE(IBKLIN) = MBKLIN(IBKLIN) 2168 100 CONTINUE 2169 ELSE 2170 NADD = 0 2171 IATOM = 0 2172 NCLAST = 0 2173 MLINE_in_upcase = MLINE(NMLINE_4) 2174 CALL UPCASE(MLINE_in_upcase) 2175 IPOS = INDEX(MLINE_in_upcase,'ATO') 2176 IF (IPOS .EQ. 0) THEN 2177 IF (MLINE(NMLINE_4)(10:10).EQ.'0') THEN 2178 MLINE(NMLINE_4)(20:20) = ' ' 2179 ELSE 2180 MLINE(NMLINE_4)(10:20) = ' ' 2181 END IF 2182 ELSE 2183 CALL LINE4(MLINE(NMLINE_4),NONTYP,NSYMOP,CRT,KCHARG,THRS, 2184 & ADDSYM,KASYM,ID3,DOCART,DOOWN) 2185 AUTOSY = .TRUE. 2186 NOSYM = .FALSE. 2187 ID3 = ' ' 2188 CALL LINE4W(MLINE(NMLINE_4),NONTYP,NSYMOP,KCHARG,THRS, 2189 & AUTOSY,NOSYM,KASYM,ID3,DOCART,DOOWN) 2190 END IF 2191 DO 200 ICENT = 1, NUCIND 2192 ISYM = 0 2193 NRLINE = NCLINE(ICENT) 2194 NC = NCLINE(ICENT) 2195 MULCNT = ISTBNU(ICENT) 2196 IF (NC .NE. 0) THEN 2197 READ (MLINE(NC),9100) NAME 2198 IPOS = INDEX(MLINE(NC),'Isotope=') 2199 IF (IPOS .NE. 0) THEN 2200 READ (MLINE(NC)(IPOS:),'(A11)') TMPTXT 2201 ELSE 2202 TMPTXT = ' ' 2203 END IF 2204 DO 300 IOP = 0, MAXOPR 2205 IF (IAND(IOP,MULCNT) .EQ. 0) THEN 2206 IATOM = IATOM + 1 2207 CRX = COOR(1,IATOM) 2208 CRY = COOR(2,IATOM) 2209 CRZ = COOR(3,IATOM) 2210 BIG = (ABS(CRX) .GE. D100 .OR. 2211 * ABS(CRY) .GE. D100 .OR. 2212 * ABS(CRZ) .GE. D100) 2213 IF (ISYM .GT. 0) THEN 2214 DO 400 I = NMLINE, NC+1, -1 2215 MLINE(I+1) = MLINE(I) 2216 400 CONTINUE 2217 DO 450 IC2 = ICENT+1, NUCIND 2218 NCLINE(IC2) = NCLINE(IC2) + 1 2219 450 CONTINUE 2220 NRLINE = NRLINE + 1 2221 NMLINE = NMLINE + 1 2222 NC = NC + 1 2223 END IF 2224 IF (BIG) THEN 2225 WRITE (MLINE(NC),9200) NAME,CRX,CRY,CRZ,TMPTXT 2226 ELSE 2227 WRITE (MLINE(NC),9300) NAME,CRX,CRY,CRZ,TMPTXT 2228 END IF 2229 ISYM = ISYM + 1 2230 END IF 2231 300 CONTINUE 2232 END IF 2233 200 CONTINUE 2234C 2235C Do a count of each type of atom.... 2236C 2237 MLINE_in_upcase = MLINE(NCLINE(1)-1) 2238 CALL UPCASE(MLINE_in_upcase) 2239 NEWINP = (INDEX(MLINE_in_upcase,'CHA') .NE. 0) 2240 KCENT2 = 0 2241 ICENT1 = 1 2242 500 CONTINUE 2243 ICENT1 = ICENT1 + KCENT2 2244 DO 700 ICENT2 = ICENT1+1, NUCIND 2245 IF (NEWINP) THEN 2246 MLINE_in_upcase = MLINE(NCLINE(ICENT2)-1) 2247 CALL UPCASE(MLINE_in_upcase) 2248 NEWATO = (INDEX(MLINE_in_upcase,'CHA') .NE. 0) 2249 ELSE 2250 READ (MLINE(NCLINE(ICENT2)-1),'(A)') CHR 2251 NEWATO = (CHR .EQ. ' ') 2252 END IF 2253 IF (NEWATO) THEN 2254 NAT = 0 2255 DO 800 IC = ICENT1, ICENT2-1 2256 NAT = NAT + NUCDEG(IC) 2257 800 CONTINUE 2258 IF (NEWINP) THEN 2259 MLINE_in_upcase = MLINE(NMLINE_1) 2260 CALL UPCASE(MLINE_in_upcase) 2261 IF (MLINE_in_upcase(1:5) .EQ. 'BASIS') BASIS = .TRUE. 2262 IF (MLINE_in_upcase(1:5) .EQ. 'ATOMB') ATOMBA = .TRUE. 2263 CALL LINE5R(MLINE(NCLINE(ICENT1) - 1),Q1,NONT1,MBSI1, 2264 & IQM1,JCO1,MXAQN,BASIS,ATOMBA,LMULBS,BSNM, 2265 & RADIUS_PCM, ALPHA_PCM) 2266! CALL LINE5W(MLINE(NCLINE(ICENT1) - 1),Q1,NAT,MBSI1, 2267! & BASIS,ATOMBA,LMULBS,BSNM,IQM1,JCO1,MXAQN, 2268! & RADIUS_PCM, ALPHA_PCM) 2269 CALL LINE5_UPD(MLINE(NCLINE(ICENT1) - 1),NAT) 2270 ELSE 2271 WRITE (MLINE(NCLINE(ICENT1)-1)(13:15),'(I3)') NAT 2272 END IF 2273 KCENT2 = ICENT2-ICENT1 2274 GOTO 500 2275 ELSE 2276 IF (ICENT2 .EQ. NUCIND) THEN 2277 KCENT1 = ICENT1 2278 GOTO 900 2279 END IF 2280 END IF 2281 700 CONTINUE 2282 KCENT1 = NUCIND 2283 900 CONTINUE 2284 NAT = 0 2285 DO 1100 IC = KCENT1, NUCIND 2286 NAT = NAT + NUCDEG(IC) 2287 1100 CONTINUE 2288 IF (NEWINP) THEN 2289 CALL LINE5R(MLINE(NCLINE(KCENT1) - 1),Q1,NONT1,MBSI1, 2290 & IQM1,JCO1,MXAQN,BASIS,ATOMBA,LMULBS,BSNM, 2291 & RADIUS_PCM, ALPHA_PCM) 2292! CALL LINE5W(MLINE(NCLINE(KCENT1) - 1),Q1,NAT,MBSI1, 2293! & BASIS,ATOMBA,LMULBS,BSNM,IQM1,JCO1,MXAQN, 2294! & RADIUS_PCM, ALPHA_PCM) 2295 CALL LINE5_UPD(MLINE(NCLINE(KCENT1) - 1),NAT) 2296 BASIS = .FALSE. 2297 ATOMBA = .FALSE. 2298 ELSE 2299 WRITE (MLINE(NCLINE(KCENT1)-1)(13:15),'(I3)') NAT 2300 END IF 2301 END IF 2302C 2303C Punch MOLECULE input with updated coordinates to LUMOL 2304C (And DALTON.OUT if manual is set.) 2305C 2306 IF (MANUAL) THEN 2307 WRITE (LUPRI,'(5X,A)') 'Molecular geometry as requested:' 2308 WRITE (LUPRI,'(5X,A,I5)') 'Number of lines printed', NMLINE 2309 END IF 2310 CALL GPOPEN(LUMOL,'MOLECULE.INP','OLD',' ','FORMATTED',IDUMMY, 2311 & .FALSE.) 2312 REWIND (LUMOL) 2313 DO 1300 IMLINE = 1,NMLINE 2314 WRITE (LUMOL,'(A)') MLINE(IMLINE) 2315 IF (MANUAL) THEN 2316 WRITE (LUPRI,'(A)') MLINE(IMLINE) 2317 END IF 2318 1300 CONTINUE 2319 CALL GPCLOSE(LUMOL,'KEEP') 2320C 2321 9100 FORMAT (A4) 2322 9200 FORMAT (A4,3F20.10,1X,A11) 2323 9300 FORMAT (A4,3F20.15,1X,A11) 2324C 2325 RETURN 2326 END 2327C 2328C /*Deck stpcor*/ 2329 SUBROUTINE STPCOR(COOR,CSTART,SYMCOR,DISPLC,NCOOR,KPM,KSCOOR, 2330 & IPRINT) 2331#include "implicit.h" 2332#include "priunit.h" 2333C 2334 DIMENSION COOR(NCOOR), CSTART(NCOOR), SYMCOR(NCOOR,NCOOR) 2335C 2336 IF (IPRINT .GT. 5) THEN 2337 CALL HEADER('CSTART in STPCOR',1) 2338 CALL OUTPUT(CSTART,1,1,1,NCOOR,1,NCOOR,1,LUPRI) 2339 END IF 2340C 2341 IF (KPM.EQ.1) THEN 2342 FAC = DISPLC 2343 ELSE 2344 FAC = -DISPLC 2345 END IF 2346 2347 DO 100 ICOOR = 1, NCOOR 2348 COOR(ICOOR) = CSTART(ICOOR) + FAC*SYMCOR(ICOOR,KSCOOR) 2349 100 CONTINUE 2350C 2351 IF (IPRINT .GT. 5) THEN 2352 CALL HEADER('COOR in STPCOR',1) 2353 CALL OUTPUT(COOR,1,1,1,NCOOR,1,NCOOR,1,LUPRI) 2354 END IF 2355C 2356 RETURN 2357 END 2358C 2359 SUBROUTINE NDER_RESET(EXHER,EXSIR,EXABA) 2360#include "implicit.h" 2361#include "priunit.h" 2362#include "mxcent.h" 2363#include "maxaqn.h" 2364#include "maxorb.h" 2365C 2366#include "ccorb.h" 2367#include "optinf.h" 2368#include "symmet.h" 2369#include "nuclei.h" 2370#include "gnrinf.h" 2371#include "huckel.h" 2372#include "trkoor.h" 2373#include "cbiwlk.h" 2374#include "past.h" 2375#include "abainf.h" 2376#include "cbinum.h" 2377#include "numder.h" 2378 LOGICAL EXHER,EXSIR,EXABA,EX 2379C 2380C This routine resets a few variables, to be able to calculate 2381C energy again for a new geometry (and symmetry). 2382C 2383 EXHER = .FALSE. 2384 EXSIR = .FALSE. 2385 EXABA = .FALSE. 2386 RDINPC = .FALSE. 2387 RDMLIN = .FALSE. 2388C 2389C *** unset ABA variable to false *** 2390C 2391 CALL ABA_UNSET() 2392C 2393C *** If there are possibilities for new symmetry. *** 2394C 2395 IF (MAXREP .gt. 0) THEN 2396 IF (((NMORDR+NAORDR).GT.1).OR.(NPRPDR)) THEN 2397 NEWSYM = .TRUE. 2398 DOHUCKEL = .TRUE. 2399 END IF 2400 END IF 2401C 2402C *** For higher order derivatives. **** 2403C 2404 IF ((NMORDR+NAORDR).GT.1) THEN 2405 HRINPC = .FALSE. 2406 KEEPHE = .FALSE. 2407 RSTARR = .TRUE. 2408 DOWALK = .FALSE. 2409 BRKSYM = .FALSE. 2410 ITRBRK = ITRNMR 2411 INDOLD = INDTOT 2412 GECONV = .FALSE. 2413 CALL IZERO(NUCNUM, MXCENT*8) 2414 CALL IZERO(NCRREP, 16) 2415 CALL IZERO(IPTCNT, MXCENT*48) 2416 CALL IZERO(NAXREP, 16) 2417 CALL IZERO(INDHES, 8) 2418C 2419C *** For analytical hessians ** 2420C 2421 ITRNMR = 1 2422 NCRTOT = NCOOR 2423 NCART = NCOOR 2424 DO I = 0, 7 2425 DOREPW(I) = .TRUE. 2426 END DO 2427 END IF 2428C 2429 IF (NPRPDR) THEN 2430 IF (SPNSPN) THEN 2431 PASTRP = .FALSE. 2432 END IF 2433 END IF 2434C 2435C *** Initialization related to doing CC. *** 2436C 2437Ctbp IF (DOCCSD) THEN 2438Ctbp DO ISYM = 1, 8 2439Ctbp DO IXFRO = 1, MAXFRO 2440Ctbp FRORHF(IXFRO,ISYM) = .FALSE. 2441Ctbp END DO 2442Ctbp END DO 2443Ctbp END IF 2444C 2445C *** For spin-spin couplings. *** 2446C 2447 CALL GPINQ('RSPVEC','EXIST',EX) 2448 IF (EX) THEN 2449 LURSP = -1 2450 CALL GPOPEN(LURSP,'RSPVEC','OLD', 2451 & ' ','UNFORMATTED',IDUMMY,.FALSE.) 2452 CALL GPCLOSE(LURSP,'DELETE') 2453 END IF 2454cC 2455c CALL GPINQ('RSPRST.E2C','EXIST',EX) 2456c IF (EX) THEN 2457c CALL GPOPEN(LURSP,'RSPRST.E2C','OLD',' ','UNFORMATTED',IDUMMY, 2458c & .FALSE.) 2459c CALL GPCLOSE(LURSP,'DELETE') 2460c END IF 2461cC 2462c CALL GPINQ('AOPROPER','EXIST',EX) 2463c IF (EX) THEN 2464c CALL GPOPEN(LURSP,'AOPROPER','OLD',' ','UNFORMATTED',IDUMMY, 2465c & .FALSE.) 2466c CALL GPCLOSE(LURSP,'DELETE') 2467c END IF 2468cC 2469c CALL GPINQ('ABACUS.RESTART','EXIST',EX) 2470c IF (EX) THEN 2471c CALL GPOPEN(LURSP,'ABACUS.RESTART','OLD',' ','UNFORMATTED', 2472c & IDUMMY,.FALSE.) 2473c CALL GPCLOSE(LURSP,'DELETE') 2474c END IF 2475cC 2476c CALL GPINQ('ABAENR.RST','EXIST',EX) 2477c IF (EX) THEN 2478c CALL GPOPEN(LURSP,'ABAENR.RST','OLD',' ','UNFORMATTED', 2479c & IDUMMY,.FALSE.) 2480c CALL GPCLOSE(LURSP,'DELETE') 2481c END IF 2482cC 2483c CALL GPINQ('ABACUS.GDT','EXIST',EX) 2484c IF (EX) THEN 2485c CALL GPOPEN(LURSP,'ABACUS.GDT','OLD',' ','UNFORMATTED', 2486c & IDUMMY,.FALSE.) 2487c CALL GPCLOSE(LURSP,'DELETE') 2488c END IF 2489cC 2490c CALL GPINQ('ABACUS.RDT','EXIST',EX) 2491c IF (EX) THEN 2492c CALL GPOPEN(LURSP,'ABACUS.RDT','OLD',' ','UNFORMATTED', 2493c & IDUMMY,.FALSE.) 2494c CALL GPCLOSE(LURSP,'DELETE') 2495c END IF 2496cC 2497c CALL GPINQ('MODRCINT','EXIST',EX) 2498c IF (EX) THEN 2499c CALL GPOPEN(LURSP,'MODRCINT','OLD',' ','UNFORMATTED', 2500c & IDUMMY,.FALSE.) 2501c CALL GPCLOSE(LURSP,'DELETE') 2502c END IF 2503C 2504 RETURN 2505 END 2506C 2507C /* Deck NMCOEF */ 2508 SUBROUTINE NMCOEF(COEFF,TCOEFF,WORK,MXCOEF,NMNMDR,LWORK) 2509#include "implicit.h" 2510#include "priunit.h" 2511 PARAMETER (D1 = 1.0D0, D05 = 0.5D0) 2512C 2513 DIMENSION COEFF (-MXCOEF:MXCOEF,0:NMNMDR), 2514 & TCOEFF(-NMNMDR:NMNMDR,0:NMNMDR), WORK(LWORK) 2515 2516C 2517 KDIM1 = (2*MXCOEF+1)*(NMNMDR+1) 2518 KDIM2 = (2*NMNMDR+1)*(NMNMDR+1) 2519 CALL DZERO(COEFF ,KDIM1) 2520 CALL DZERO(TCOEFF,KDIM2) 2521 COEFF(0,0) = D1 2522C 2523C *** Temporary coefficients used to generate coefficients *** 2524C *** for even-numbered derivatives. *** 2525C 2526 IF (NMNMDR .GT. 1) THEN 2527 NCOR = 1 2528 TCOEFF(0,0) = D1 2529 DO 100 IDR = 1, NMNMDR 2530 DO 200 ICOR = -IDR+1, IDR-1 2531 TCOEFF(ICOR,IDR) = TCOEFF(ICOR-1,IDR-1) 2532 & - TCOEFF(ICOR+1,IDR-1) 2533 200 CONTINUE 2534C 2535 TCOEFF(-IDR,IDR) = (-D1)**IDR 2536 TCOEFF( IDR,IDR) = D1 2537C 2538 100 CONTINUE 2539C 2540C *** Coefficients for even-numbered derivatives *** 2541C 2542 COEFF(0,0) = D1 2543 NEVEN = INT(NMNMDR/2) 2544 DO 300 IEVEN = 1, NEVEN 2545 IDR = 2*IEVEN 2546 DO 400 IECOR = -IEVEN,IEVEN 2547 ICOR = 2*IECOR 2548 COEFF(IECOR,IDR) = TCOEFF(ICOR,IDR) 2549 400 CONTINUE 2550 300 CONTINUE 2551 END IF 2552C 2553C *** Coefficients for odd-numbered derivatives *** 2554C 2555 NODD = INT((NMNMDR+1)/2) 2556 DO 500 IODD = 1, NODD 2557 IDR = 2*IODD - 1 2558 DO 600 IOCOR = -IODD+1, IODD-1 2559 IF (IOCOR .NE. 0) THEN 2560 COEFF(IOCOR,IDR) = D05*(COEFF(IOCOR-1,IDR-1) 2561 & - COEFF(IOCOR+1,IDR-1)) 2562 END IF 2563 600 CONTINUE 2564C 2565 COEFF(-IODD,IDR) = -D05 2566 COEFF( IODD,IDR) = D05 2567C 2568 500 CONTINUE 2569C 2570 RETURN 2571 END 2572C 2573C 2574C /* Deck NMNDER */ 2575 SUBROUTINE NMNDER(DERIV,COEFF,FUNVAL,GRIREP,WORK,IADRSS,KDPMTX, 2576 & ICRIRP,INDSTP,INDTMP,IDCOMP,IMAX,IMIN,ICNT, 2577 & NCVAL,IDDCMP,MXCOEF,NORDR,NDIME,NTYPE,NDERIV, 2578 & NFINNR,LDPMTX,IFRSTD,NLDPMX,LWORK,FCCAL) 2579#include "implicit.h" 2580#include "priunit.h" 2581#include "mxcent.h" 2582 PARAMETER (DMIN = 1.0D-12, D1=1.0D0, D0=0.0D0) 2583#include "taymol.h" 2584#include "moldip.h" 2585#include "trkoor.h" 2586#include "cbiwlk.h" 2587#include "cbinum.h" 2588#include "numder.h" 2589#include "fcsym.h" 2590#include "dummy.h" 2591 LOGICAL CLFVAL, FCCAL, DIAGON 2592 DIMENSION COEFF(-MXCOEF:MXCOEF,0:NORDR), DERIV(NDERIV), 2593 & FUNVAL(NFINNR,NDIME), GRIREP(NGORDR,NGVERT), WORK(LWORK) 2594 DIMENSION ICNT(NTYPE), IADRSS(NTYPE), IMAX(NORDR), IMIN(NORDR), 2595 & INDSTP(NTORDR), INDTMP(NTORDR), IDCOMP(NCOOR), 2596 & IDDCMP(NCOOR), NCVAL(NCOOR), 2597 & KDPMTX(LDPMTX,NSTRDR,IFRSTD), ICRIRP(NCOOR,2) 2598 2599 REAL*8 GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 2600C 2601 CALL QENTER('NMNDER') 2602C 2603 IF (FCCAL) THEN 2604 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 2605 IF (NAORDR .LT. 1) GRDMOL(:) = 0.0D0 2606 IF (NAORDR .LT. 2) HESMOL(:,:) = 0.0D0 2607 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 2608 END IF 2609 IF (NDERIV .GT. 0) CALL DZERO(DERIV,NDERIV) 2610C 2611C *************************************************** 2612C *** This subroutine calculates the coefficients *** 2613C *** for the numerical differentiation. *** 2614C *************************************************** 2615C 2616 KTCOEF = 1 2617 KLAST = KTCOEF + (2*NORDR+1)*(NORDR+1) 2618 LWRK = LWORK - KLAST + 1 2619 CALL NMCOEF(COEFF,WORK(KTCOEF),WORK(KLAST),MXCOEF,NORDR,LWORK) 2620C 2621 IDERIV = 0 2622 DO 100 IORDR = 1, NORDR 2623C 2624 ! DIAGON = only diagonal needed 2625 DIAGON = (.NOT.FCCAL ).AND.(IORDR.EQ.NORDR).AND. 2626 & PRPVIB .AND.((NARDRP+NMRDRP).EQ.2) 2627 2628C *********************************************** 2629C *** Special code for gradients and hessians *** 2630C *** due to special memory places. *** 2631C *********************************************** 2632C 2633 IF (((IORDR+NAORDR).LE.2).AND.FCCAL) THEN 2634 2635 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 2636 2637 IF ((IORDR+NAORDR).EQ.1) THEN 2638C 2639C **************************************** 2640C *** Numerical gradient from energies *** 2641C **************************************** 2642C 2643 IMAX(1) = 1 2644 IMIN(1) = -1 2645 IDIME = 1 2646 HINV = D1/DISPLC 2647 DO 200 ICOOR = 1, NCOOR 2648 DO 200 I = IMAX(1), IMIN(1), -2 2649 IF (COEFF(I,1)**2 .GT. DMIN) THEN 2650 IDIME = IDIME + 1 2651 GRDMOL(ICOOR) = GRDMOL(ICOOR) 2652 & + COEFF(I,1)*FUNVAL(1,IDIME)*HINV 2653 END IF 2654 200 CONTINUE 2655 ELSE 2656C 2657C ***************************************** 2658C *** Numerical Hessian and dipole gradient 2659C *** from analytical gradients and dipoles 2660C ***************************************** 2661C 2662 IF (NAORDR .EQ. 1) THEN 2663 IDIME = 2 2664 HINV = D1/DISPLC 2665 DO ICOOR2 = 1, NCOOR 2666 DO ICOOR1 = 1, NCOOR 2667 HESMOL(ICOOR1,ICOOR2) = 2668 & (COEFF( 1,1)*FUNVAL(ICOOR1,IDIME) 2669 & + COEFF(-1,1)*FUNVAL(ICOOR1,IDIME+1))*HINV 2670 END DO 2671 DIP1(1,ICOOR2) = 2672 & (COEFF( 1,1)*FUNVAL(NCOOR+1,IDIME) 2673 & + COEFF(-1,1)*FUNVAL(NCOOR+1,IDIME+1))*HINV 2674 DIP1(2,ICOOR2) = 2675 & (COEFF( 1,1)*FUNVAL(NCOOR+2,IDIME) 2676 & + COEFF(-1,1)*FUNVAL(NCOOR+2,IDIME+1))*HINV 2677 DIP1(3,ICOOR2) = 2678 & (COEFF( 1,1)*FUNVAL(NCOOR+3,IDIME) 2679 & + COEFF(-1,1)*FUNVAL(NCOOR+3,IDIME+1))*HINV 2680 IDIME = IDIME + 2 2681 END DO 2682 ELSE 2683C 2684C ****************************** 2685C *** Numerical Hessian from *** 2686C *** energies. *** 2687C ****************************** 2688C 2689 CALL IZERO(ICNT,NTYPE) 2690C 2691 IMAX(1) = 1 2692 IMIN(1) = -1 2693 HINV = D1/(DISPLC**2) 2694 DO 300 IX2 = 1, NDCOOR 2695 DO 300 IX1 = 1, IX2 2696C 2697 CALL IZERO(INDSTP,NMORDR) 2698 INDSTP(1) = IX2 2699 INDSTP(2) = IX1 2700C 2701C *** Checking whether this component should *** 2702C *** not be calculated, due to symmetry. *** 2703C 2704 KIDTMP = 1 2705 KIDDBT = KIDTMP + NORDR 2706 KIRPDG = KIDDBT + NORDR 2707 KIRPST = KIRPDG + NORDR 2708 KLAST = KIRPST + NORDR 2709 LWRK = LWORK - KLAST + 1 2710 CALL FCSCRN(GRIREP,WORK(KLAST),KDPMTX,INDSTP, 2711 & ICRIRP,IDUMMY,WORK(KIDTMP),WORK(KIDDBT), 2712 & WORK(KIRPDG),WORK(KIRPST),IDUMMY,LWORK,NLDPMX, 2713 & LDPMTX,IFRSTD,IORDR,IORDR-1,IDUMMY,IDUMMY, 2714 & IDUMMY,IPRINT,CLFVAL,.FALSE.,.FALSE.,.TRUE.) 2715C 2716 MX = IMIN(1) 2717 IF (IX1 .EQ. IX2) MX = IMAX(1) 2718 DO 400 I2 = IMAX(1), IMIN(1),-1 2719 DO 400 I1 = IMAX(1), MX, -1 2720 IF (IX1 .EQ. IX2) THEN 2721 IF (I2.EQ.0) THEN 2722 ITYPE = 1 2723 ICNT(ITYPE) = 0 2724 BCOEFF = COEFF(0,2) 2725 ELSE 2726 ITYPE = 2 2727 BCOEFF = COEFF(I2,2) 2728 END IF 2729 ELSE 2730 ITYPE = 3 2731 BCOEFF = COEFF(I1,1)*COEFF(I2,1) 2732 END IF 2733C 2734 IF (BCOEFF**2 .GT. DMIN) THEN 2735 ICNT(ITYPE) = ICNT(ITYPE) + 1 2736 IF (CLFVAL) THEN 2737 HESMOL(IX2,IX1) = HESMOL(IX2,IX1) 2738 & + BCOEFF*HINV 2739 & * FUNVAL(1,IADRSS(ITYPE)+ICNT(ITYPE)) 2740 END IF 2741 END IF 2742 400 CONTINUE 2743 300 CONTINUE 2744 END IF 2745 END IF 2746 2747 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 2748 2749 ELSE IF ((ANALZ1).AND.((NMORDR+NAORDR).EQ.3).AND.NRMCRD.AND. 2750 & (FCCAL ).AND. (IORDR.EQ.2).AND.(NAORDR.EQ.1)) THEN 2751C 2752C **************************************************************** 2753C *** Special case for cases were only vib. average of *** 2754C *** properties in ANALZ1 method from gradients in normal *** 2755C *** coordinates. *** 2756C *** ANALZ1 -> Use ANALZ1 method. *** 2757C *** NMORDR+NAORDR = 3 -> Calculate up to cubic force field. *** 2758C *** When ANALZ1 is also used, then only *** 2759C *** parts of the cubic force field is *** 2760C *** calculated. *** 2761C *** NRMCRD -> Normal coordinates. *** 2762C *** NAORDR = 1 -> Analytical gradients *** 2763C **************************************************************** 2764C 2765 ISORDR = IORDR+1 2766 NINNR2 = 0 2767C 2768 NSTP = 1 2769 DO I = 1, ISORDR 2770 NSTP = NSTP*(NDCOOR+I-1)/I 2771 END DO 2772 POWER = DBLE(IORDR) 2773 DIVDIS = D1/(DISPLC**POWER) 2774C 2775 CALL IZERO(INDSTP,NMORDR+NAORDR) 2776C 2777C *** NSTP -> Number of components in the *** 2778C *** numerical differentiation *** 2779C 2780 DO ISTP = 1, NSTP 2781C 2782C *** Finding which component this is *** 2783C 2784 DO IC = ISORDR, 1, -1 2785 IF (IC .EQ. 1) THEN 2786 INDSTP(1) = INDSTP(1) + 1 2787 DO I = 2, ISORDR 2788 INDSTP(I) = 1 2789 END DO 2790 GOTO 500 2791 ELSE IF (INDSTP(IC) .LE. INDSTP(IC-1)-1) THEN 2792 DO I = IC+1, ISORDR 2793 INDSTP(I) = 1 2794 END DO 2795 INDSTP(IC) = INDSTP(IC) + 1 2796 GOTO 500 2797 END IF 2798 END DO 2799 500 CONTINUE 2800C 2801C *** First indices in INDSTP are kept for the *** 2802C *** analytical derivative. *** 2803C 2804 CALL SRTINS(INDSTP,INDTMP) 2805 2806C *** Checking whether this component should *** 2807C *** not be calculated, due to symmetry. *** 2808C 2809 CLFVAL = .TRUE. 2810c IF (FCCAL) THEN 2811c KIDTMP = 1 2812c KIDDBT = KIDTMP + NORDR 2813c KIRPDG = KIDDBT + NORDR 2814c KIRPST = KIRPDG + NORDR 2815c KLAST = KIRPST + NORDR 2816c LWRK = LWORK - KLAST + 1 2817c CALL FCSCRN(GRIREP,WORK(KLAST),KDPMTX,INDTMP,ICRIRP, 2818c & IDUMMY,WORK(KIDTMP),WORK(KIDDBT), 2819c & WORK(KIRPDG),WORK(KIRPST),IDUMMY,LWORK, 2820c & NLDPMX,LDPMTX,IFRSTD,IORDR,IORDR-1,IDUMMY, 2821c & IDUMMY,IDUMMY,IPRINT,CLFVAL,.FALSE., 2822c & .FALSE.,.TRUE.) 2823c END IF 2824C 2825 IDERIV = IDERIV + 1 2826C 2827 IF (CLFVAL) THEN 2828C 2829 CALL IZERO(NCVAL,NDCOOR) 2830 DO IC = 1, IORDR 2831 NCVAL(INDTMP(IC)) = NCVAL(INDTMP(IC)) + 1 2832 END DO 2833C 2834C ******************************************************* 2835C *** IDCOMP -> Maks steporder to get the derivative *** 2836C *** IDDCMP -> Counting array, maks to min steporder *** 2837C *** NTTYPE -> Number of function values needed for *** 2838C *** 1 component *** 2839C ******************************************************* 2840C 2841 NTTYPE = 1 2842 CALL IZERO(IDCOMP,NDCOOR) 2843 CALL IZERO(IDDCMP,NDCOOR) 2844 DO IC = 1, NDCOOR 2845 IF (NCVAL(IC) .NE. 0) THEN 2846 IDCOMP(IC) = INT((NCVAL(IC)+1)/2) 2847 NTTYPE = NTTYPE*(2*IDCOMP(IC) + 1) 2848 END IF 2849 END DO 2850 DO I=1,NDCOOR 2851 IDDCMP(I) = IDCOMP(I) 2852 END DO 2853C 2854 DO ITTYPE = 1, NTTYPE 2855C 2856C *** Finding the right indices to identify *** 2857C *** the right function value *** 2858C 2859 DO IC = 1, NDCOOR 2860 IF ((IDDCMP(IC) .GT. -IDCOMP(IC)) 2861 & .AND. (ITTYPE .NE. 1)) THEN 2862 IDDCMP(IC) = IDDCMP(IC) - 1 2863 DO ICT = 1, IC-1 2864 IDDCMP(ICT) = IDCOMP(ICT) 2865 END DO 2866 GOTO 600 2867 END IF 2868 END DO 2869 600 CONTINUE 2870C 2871C *** Calculate the coefficient for this *** 2872C *** function value *** 2873C 2874 BCOEFF = D1 2875 NUMCOF = 0 2876 DO IC = 1, NDCOOR 2877 IF (NCVAL(IC) .NE. 0) THEN 2878 BCOEFF = BCOEFF*COEFF(IDDCMP(IC),NCVAL(IC)) 2879 NUMCOF = NUMCOF + 1 2880 END IF 2881 END DO 2882 IF (NUMCOF .EQ. 0) BCOEFF = D0 2883C 2884C *** Does the function value contribute? *** 2885C 2886 IF (BCOEFF**2 .GT. DMIN) THEN 2887C 2888C ************************************************ 2889C *** This subroutine finds the adress for the *** 2890C *** function value, from the indices *** 2891C *** NEIND - The adress in the FUNVAL-array *** 2892C ************************************************ 2893C 2894 KITCMP = 1 2895 CALL GTEIND(IADRSS,IDDCMP,NCVAL,WORK(KITCMP), 2896 & NEIND,ITTYPE,NORDR,IORDR) 2897C 2898C *** The derivative is calculated. *** 2899C 2900 DERIV(IDERIV) = DERIV(IDERIV) 2901 & + BCOEFF*FUNVAL(INDTMP(3),NEIND) 2902C 2903 END IF 2904 END DO 2905 DERIV(IDERIV) = DERIV(IDERIV)*DIVDIS 2906 END IF 2907 END DO 2908 ELSE 2909C 2910C ********************************************* 2911C *** Numerical N'th derivative from NAORDR *** 2912C *** analytival derivative *** 2913C ********************************************* 2914C 2915 NINNR2 = 0 2916C 2917 NSTP = 1 2918 DO I = 1, IORDR 2919 NSTP = NSTP*(NDCOOR+I-1)/I 2920 END DO 2921 POWER = DBLE(IORDR) 2922 DIVDIS = D1/(DISPLC**POWER) 2923C 2924 CALL IZERO(INDSTP,NMORDR) 2925C 2926C *** NSTP -> Number of components in the *** 2927C *** numerical differentiation *** 2928C 2929 DO ISTP = 1, NSTP 2930C 2931C *** Finding which component this is *** 2932C 2933 DO IC = IORDR, 1, -1 2934 IF (IC .EQ. 1) THEN 2935 INDSTP(1) = INDSTP(1) + 1 2936 DO I = 2, IORDR 2937 INDSTP(I) = 1 2938 END DO 2939 GOTO 700 2940 ELSE IF (INDSTP(IC) .LE. INDSTP(IC-1)-1) THEN 2941 DO I = IC+1, IORDR 2942 INDSTP(I) = 1 2943 END DO 2944 INDSTP(IC) = INDSTP(IC) + 1 2945 GOTO 700 2946 END IF 2947 END DO 2948 700 CONTINUE 2949C 2950C *** Checking whether this component should *** 2951C *** not be calculated, due to symmetry. *** 2952C 2953 IF (FCCAL) THEN 2954 KIDTMP = 1 2955 KIDDBT = KIDTMP + NORDR 2956 KIRPDG = KIDDBT + NORDR 2957 KIRPST = KIRPDG + NORDR 2958 KLAST = KIRPST + NORDR 2959 LWRK = LWORK - KLAST + 1 2960 CALL FCSCRN(GRIREP,WORK(KLAST),KDPMTX,INDSTP,ICRIRP, 2961 & IDUMMY,WORK(KIDTMP),WORK(KIDDBT), 2962 & WORK(KIRPDG),WORK(KIRPST),IDUMMY,LWORK, 2963 & NLDPMX,LDPMTX,IFRSTD,IORDR,IORDR-1,IDUMMY, 2964 & IDUMMY,IDUMMY,IPRINT,CLFVAL,.FALSE., 2965 & .FALSE.,.TRUE.) 2966 ELSE 2967 CLFVAL = .TRUE. 2968 END IF 2969C 2970C *** In some calculations we only need diagonal *** 2971C *** derivatives. *** 2972C 2973 IF ((IORDR.GT.1).AND.DIAGON) THEN 2974 CLFVAL = (CLFVAL).AND. 2975 & (INDSTP(IORDR-1).EQ.INDSTP(IORDR)) 2976 END IF 2977C 2978C *** The number of innermost elements. *** 2979C 2980 IF (FCCAL) THEN 2981 NINNR2 = 1 2982 IF (NAORDR .GE. 1) THEN 2983 NINNR2 = INDSTP(IORDR) 2984 END IF 2985 IF (NAORDR .GE. 2) THEN 2986 NINNR2 = NINNR2*(INDSTP(IORDR)+1)/2 2987 END IF 2988 ELSE 2989 NINNR2 = NFINNR 2990 END IF 2991C 2992 IF (CLFVAL) THEN 2993C 2994 CALL IZERO(NCVAL,NDCOOR) 2995 DO IC = 1, IORDR 2996 NCVAL(INDSTP(IC)) = NCVAL(INDSTP(IC)) + 1 2997 END DO 2998C 2999C ******************************************************* 3000C *** IDCOMP -> Maks steporder to get the derivative *** 3001C *** IDDCMP -> Counting array, maks to min steporder *** 3002C *** NTTYPE -> Number of function values needed for *** 3003C *** 1 component *** 3004C ******************************************************* 3005C 3006 NTTYPE = 1 3007 CALL IZERO(IDCOMP,NDCOOR) 3008 CALL IZERO(IDDCMP,NDCOOR) 3009 DO IC = 1, NDCOOR 3010 IF (NCVAL(IC) .NE. 0) THEN 3011 IDCOMP(IC) = INT((NCVAL(IC)+1)/2) 3012 NTTYPE = NTTYPE*(2*IDCOMP(IC) + 1) 3013 END IF 3014 END DO 3015 DO I=1,NDCOOR 3016 IDDCMP(I) = IDCOMP(I) 3017 END DO 3018C 3019 DO ITTYPE = 1, NTTYPE 3020C 3021C *** Finding the right indices to identify *** 3022C *** the right function value *** 3023C 3024 DO IC = 1, NDCOOR 3025 IF ((IDDCMP(IC) .GT. -IDCOMP(IC)) 3026 & .AND. (ITTYPE .NE. 1)) THEN 3027 IDDCMP(IC) = IDDCMP(IC) - 1 3028 DO ICT = 1, IC-1 3029 IDDCMP(ICT) = IDCOMP(ICT) 3030 END DO 3031 GOTO 800 3032 END IF 3033 END DO 3034 800 CONTINUE 3035C 3036C *** Calculate the coefficient for this *** 3037C *** function value *** 3038C 3039 BCOEFF = D1 3040 NUMCOF = 0 3041 DO IC = 1, NDCOOR 3042 IF (NCVAL(IC) .NE. 0) THEN 3043 BCOEFF = BCOEFF*COEFF(IDDCMP(IC),NCVAL(IC)) 3044 NUMCOF = NUMCOF + 1 3045 END IF 3046 END DO 3047 IF (NUMCOF .EQ. 0) BCOEFF = D0 3048C 3049C *** Does the function value contribute? *** 3050C 3051 IF (BCOEFF**2 .GT. DMIN) THEN 3052C 3053C ************************************************ 3054C *** This subroutine finds the address for *** 3055C *** the function value, from the indices *** 3056C *** NEIND - The address in the FUNVAL-array *** 3057C ************************************************ 3058C 3059 KITCMP = 1 3060c NINTIN = 1 3061c IF (FCCAL) NINTIN = NINNR2 3062 CALL GTEIND(IADRSS,IDDCMP,NCVAL,WORK(KITCMP), 3063 & NEIND,ITTYPE,NORDR,IORDR) 3064C 3065C *** The derivative is calculated. *** 3066C 3067 DO INNER = 1, NINNR2 3068 ID = IDERIV + INNER 3069 DERIV(ID) = DERIV(ID) 3070 & + BCOEFF*FUNVAL(INNER,NEIND) 3071 END DO 3072C 3073 END IF 3074 END DO 3075C 3076C *** The derivative is correctly scaled. *** 3077C 3078 SCLFCK = D1 3079 DO INNER = 1, NINNR2 3080 ID = IDERIV + INNER 3081 DERIV(ID) = DERIV(ID)*DIVDIS*SCLFCK 3082 END DO 3083 END IF 3084 IDERIV = IDERIV + NINNR2 3085 END DO 3086 END IF 3087C 3088 100 CONTINUE 3089C 3090 CALL QEXIT('NMNDER') 3091 RETURN 3092 END 3093C 3094C 3095C /*Deck gteind*/ 3096 SUBROUTINE GTEIND(IADRSS,INDCMP,NCVAL,ITCMP,NEIND,NMTYPE,NORDR, 3097 & IORDR) 3098C 3099C ************************************************************************* 3100C *** This routine finds the adress of the function-value (in numerical *** 3101C *** differentiation) and returns it. *** 3102C *** NEIND -> The adress of the function value. *** 3103C *** IADRSS -> Adress of the start of the steporder *** 3104C *** NSTP -> Number of function-component within the order *** 3105C *** NDISP -> Number value within the component. *** 3106C ************************************************************************* 3107C 3108#include "implicit.h" 3109#include "priunit.h" 3110#include "mxcent.h" 3111C 3112#include "trkoor.h" 3113#include "numder.h" 3114 DIMENSION IADRSS(NMTYPE), INDCMP(NCOOR), ITCMP(NORDR), 3115 & NCVAL(NCOOR) 3116C 3117 CALL IZERO(ITCMP,NORDR) 3118C 3119C *** Preliminary components *** 3120C 3121 IRSRDR = 0 3122 NMX = 0 3123 ITOT = 0 3124 ITWOTT = 0 3125 DO 100 I = NDCOOR, 1, -1 3126 IF (INDCMP(I) .NE. 0) THEN 3127 IRSRDR = IRSRDR + 1 3128 ITOT = ITOT + ABS(INDCMP(I)) 3129 ITWOTT = ITWOTT + (2*ABS(INDCMP(I))-1) 3130 ITCMP(IRSRDR) = I 3131 IF (ABS(INDCMP(I)) .GT. NMX) THEN 3132 NMX = ABS(INDCMP(I)) 3133 NICMX = I 3134 END IF 3135 END IF 3136 100 CONTINUE 3137 NRSRDR = IRSRDR 3138C 3139 ITYPE = 1 3140 DO 300 IRDR = 1, ITWOTT-1 3141 IHORDR = INT((IRDR+1)/2) 3142 DO 400 IMXRDR = 1, IHORDR 3143 ITYPE = ITYPE + 1 3144 400 CONTINUE 3145 300 CONTINUE 3146 NTYPE = ITYPE + NMX 3147C 3148 IF (NMX .EQ. 0) THEN 3149 ISTP = 1 3150C 3151 ELSE IF (NMX .EQ. 1) THEN 3152 ISTP = 0 3153 DO 500 IRS1 = 1, NRSRDR - 1 3154 ITISTP = 1 3155 DO 600 I = 1, NRSRDR-IRS1+1 3156 ITISTP = ITISTP*(ITCMP(IRS1)-I)/I 3157 600 CONTINUE 3158 ISTP = ISTP + ITISTP 3159 500 CONTINUE 3160 ISTP = ISTP + ITCMP(NRSRDR) 3161C 3162C 3163C 3164 ELSE 3165 IF (ITOT .EQ. NMX) THEN 3166 ISTP = ITCMP(1) 3167 ELSE 3168 IF (ITCMP(1) .NE. NICMX) THEN 3169 ITMP1 = ITCMP(1) 3170 ITCMP(1) = NICMX 3171 DO 650 I = 2, NRSRDR 3172 ITMP2 = ITCMP(I) 3173 ITCMP(I) = ITMP1 3174 ITMP1 = ITMP2 3175 650 CONTINUE 3176 END IF 3177C 3178 ISTP = 0 3179 ISTP = (ITCMP(1)-1)*(NDCOOR-1) + ITCMP(2) 3180 IF (NICMX .LT. ITCMP(2)) ISTP = ISTP - 1 3181C 3182 DO 700 IRS1 = 3, NRSRDR-1 3183 ITISTP = 1 3184 DO 800 I = 1, NRSRDR-IRS1+1 3185 ITISTP = ITISTP*(ITCMP(IRS1)-I)/I 3186 800 CONTINUE 3187 ISTP = ISTP + ITISTP 3188 700 CONTINUE 3189 IF (NRSRDR .GT. 2) ISTP = ISTP + ITCMP(NRSRDR) 3190 END IF 3191 END IF 3192 NINNER = 2**NRSRDR 3193 NSTP = (ISTP-1)*NINNER 3194C 3195 NDISP = 1 3196 IORD = NRSRDR-1 3197 DO 900 IRS = NRSRDR, 2, -1 3198 IDISP = 0 3199 IF (INDCMP(ITCMP(IRS)) .LT. 0) THEN 3200 IDISP = 2**(IORD) 3201 END IF 3202 IORD = IORD - 1 3203 NDISP = NDISP + IDISP 3204 900 CONTINUE 3205 IF (ITCMP(1) .NE. 0) THEN 3206 IF (INDCMP(ITCMP(1)) .LE. 0) NDISP = NDISP + 1 3207 END IF 3208C 3209 NEIND = IADRSS(NTYPE) + (NSTP + NDISP) 3210C 3211 RETURN 3212 END 3213C 3214C /*Deck pritdr*/ 3215 SUBROUTINE PRITDR(TMPTDR,SYMCOR,TDER,SYMTDR,NTMPDM,NUMCOR,LTXT, 3216 & IPRINT,PRWHLE,TEXT) 3217#include "implicit.h" 3218#include "priunit.h" 3219#include "mxcent.h" 3220#include "maxorb.h" 3221#include "maxaqn.h" 3222 PARAMETER (KCOL=6) 3223#include "trkoor.h" 3224#include "symmet.h" 3225#include "numder.h" 3226#include "fcsym.h" 3227#include "cbinum.h" 3228 CHARACTER*(*) TEXT 3229 LOGICAL PRWHLE 3230 DIMENSION TDER(NCOOR,NCOOR,NCOOR), TMPTDR(NTMPDM), 3231 & SYMTDR(NCOOR,NCOOR,NCOOR), SYMCOR(NCOOR,NCOOR) 3232C 3233C ***************************************** 3234C *** Assigning values to proper places *** 3235C *** according to permutational sym. *** 3236C ***************************************** 3237C 3238 ITMP = 0 3239 DO 100 K = 1, NUMCOR 3240 DO 100 J = 1, K 3241 DO 100 I = 1, J 3242 ITMP = ITMP + 1 3243 SYMTDR(I,J,K) = TMPTDR(ITMP) 3244 SYMTDR(I,K,J) = TMPTDR(ITMP) 3245 SYMTDR(J,I,K) = TMPTDR(ITMP) 3246 SYMTDR(J,K,I) = TMPTDR(ITMP) 3247 SYMTDR(K,I,J) = TMPTDR(ITMP) 3248 SYMTDR(K,J,I) = TMPTDR(ITMP) 3249 100 CONTINUE 3250C 3251C ************************************** 3252C *** Printing symmetric coordinates *** 3253C *** Cartesian if no symmetry *** 3254C ************************************** 3255C 3256 IF (PRWHLE) THEN 3257 IF (.NOT.MINOUT) THEN 3258 CALL PRTDER(SYMTDR,NCOOR,NUMCOR,TEXT,LTXT,IPRINT) 3259 ELSE 3260 WRITE (LUPRI,'(A/)') 3261 * " Output of third derivative suppressed" 3262 ENDIF 3263 ELSE 3264 CALL HEADER('Diagonal of cubic force field, F(I,J,J)',-1) 3265C 3266 ISTRT = 1 3267 LAST = MIN(NDCOOR,KCOL) 3268 KCOOR = NDCOOR 3269 NCOL = NDCOOR/KCOL 3270 IF (MOD(NDCOOR,KCOL).NE.0) NCOL = NCOL + 1 3271C 3272 DO ICOL = 1, NCOL 3273 DO ICOOR = 1, NDCOOR 3274 WRITE (LUPRI,'(5X,6F12.6)') 3275 & (SYMTDR(ICOOR,I,I),I=ISTRT,LAST) 3276 END DO 3277 WRITE (LUPRI,'(A)') ' ' 3278 ISTRT = ISTRT + KCOL 3279 LAST = MIN(NDCOOR,KCOL+LAST) 3280 END DO 3281 END IF 3282C 3283C ************************************ 3284C *** Transformation to cartesian *** 3285C *** coordinates, and printing. *** 3286C ************************************ 3287C 3288 IF ((FCLASS(1:3) .NE. 'C1 ').AND.(TEXT(1:6).NE.'normal')) THEN 3289 LTXT = 9 3290 TEXT(1:9) = 'cartesian' 3291C 3292 CALL TRATDR(SYMCOR,SYMTDR,TDER,NCOOR,NCOOR,NCOOR,TEXT,LTXT, 3293 & IPRINT) 3294C 3295 IF (.NOT.MINOUT) 3296 & CALL PRTDER(TDER,NCOOR,NUMCOR,TEXT,LTXT,IPRINT) 3297 ELSE 3298 CALL DCOPY(NCOOR**3,SYMTDR,1,TDER,1) 3299 END IF 3300C 3301 RETURN 3302 END 3303 3304C 3305C /*Deck tratdr*/ 3306 SUBROUTINE TRATDR(TRCOOR,CR1TDR,CR2TDR,NMCOR1,NMCOR2,NCOOR,TEXT, 3307 & LTXT,IPRINT) 3308C *********************************************************** 3309C *** Transforming a third derivative into another set of *** 3310C *** coordinates. Tracor is the transformation matrix. *** 3311C *********************************************************** 3312#include "implicit.h" 3313#include "priunit.h" 3314 CHARACTER*(*) TEXT 3315 DIMENSION CR1TDR(NCOOR,NCOOR,NCOOR), CR2TDR(NCOOR,NCOOR,NCOOR), 3316 & TRCOOR(NCOOR,NCOOR) 3317C 3318 CALL DZERO(CR2TDR,NCOOR**3) 3319C 3320 DO 100 ICR1C3 = 1, NMCOR1 3321 DO 100 ICR1C2 = 1, NMCOR1 3322 DO 100 ICR1C1 = 1, NMCOR1 3323 DO 100 ICR2C1 = 1, NMCOR2 3324 CR2TDR(ICR2C1,ICR1C2,ICR1C3) = CR2TDR(ICR2C1,ICR1C2,ICR1C3) 3325 & + TRCOOR(ICR2C1,ICR1C1)*CR1TDR(ICR1C1,ICR1C2,ICR1C3) 3326 100 CONTINUE 3327C 3328 CALL DZERO(CR1TDR,NCOOR**3) 3329 DO 200 ICR1C3 = 1, NMCOR1 3330 DO 200 ICR1C2 = 1, NMCOR1 3331 DO 200 ICR2C2 = 1, NMCOR2 3332 DO 200 ICR2C1 = 1, NMCOR2 3333 CR1TDR(ICR2C1,ICR2C2,ICR1C3) = CR1TDR(ICR2C1,ICR2C2,ICR1C3) 3334 & + TRCOOR(ICR2C2,ICR1C2)*CR2TDR(ICR2C1,ICR1C2,ICR1C3) 3335 200 CONTINUE 3336C 3337 CALL DZERO(CR2TDR,NCOOR**3) 3338 DO 300 ICR1C3 = 1, NMCOR1 3339 DO 300 ICR2C3 = 1, NMCOR2 3340 DO 300 ICR2C2 = 1, NMCOR2 3341 DO 300 ICR2C1 = 1, NMCOR2 3342 CR2TDR(ICR2C1,ICR2C2,ICR2C3) = CR2TDR(ICR2C1,ICR2C2,ICR2C3) 3343 & + TRCOOR(ICR2C3,ICR1C3)*CR1TDR(ICR2C1,ICR2C2,ICR1C3) 3344 300 CONTINUE 3345C 3346 IF (IPRINT .GT.6) THEN 3347 WRITE (LUPRI,'(A)') 'Transformation tensor: ' 3348 CALL PRTRMA(TRCOOR,NCOOR,NCOOR,NMCOR2,NMCOR1,LUPRI) 3349 CALL PRTDER(CR2TDR,NCOOR,NMCOR2,TEXT,LTXT,IPRINT) 3350 END IF 3351C 3352 RETURN 3353 END 3354C 3355C /*Deck prifdr*/ 3356 SUBROUTINE PRIFDR(TMPFDR,SYMCOR,FDER,SYMFDR,NTMPDM,NUMCOR,LTXT, 3357 & IPRINT,TEXT) 3358#include "implicit.h" 3359#include "priunit.h" 3360#include "mxcent.h" 3361#include "maxaqn.h" 3362#include "maxorb.h" 3363C 3364#include "trkoor.h" 3365#include "symmet.h" 3366#include "numder.h" 3367#include "fcsym.h" 3368#include "cbinum.h" 3369 CHARACTER*(*) TEXT 3370 DIMENSION FDER(NCOOR,NCOOR,NCOOR,NCOOR), TMPFDR(NTMPDM), 3371 & SYMFDR(NCOOR,NCOOR,NCOOR,NCOOR), SYMCOR(NCOOR,NCOOR) 3372C 3373C ***************************************** 3374C *** Assigning values to proper places *** 3375C *** according to permutational sym. *** 3376C ***************************************** 3377C 3378 ITMP = 0 3379 DO 100 L = 1, NUMCOR 3380 DO 100 K = 1, L 3381 DO 100 J = 1, K 3382 DO 100 I = 1, J 3383 ITMP = ITMP + 1 3384C 3385 SYMFDR(I,J,K,L) = TMPFDR(ITMP) 3386 SYMFDR(I,J,L,K) = TMPFDR(ITMP) 3387 SYMFDR(I,K,J,L) = TMPFDR(ITMP) 3388 SYMFDR(I,K,L,J) = TMPFDR(ITMP) 3389 SYMFDR(I,L,J,K) = TMPFDR(ITMP) 3390 SYMFDR(I,L,K,J) = TMPFDR(ITMP) 3391C 3392 SYMFDR(J,I,K,L) = TMPFDR(ITMP) 3393 SYMFDR(J,I,L,K) = TMPFDR(ITMP) 3394 SYMFDR(J,K,I,L) = TMPFDR(ITMP) 3395 SYMFDR(J,K,L,I) = TMPFDR(ITMP) 3396 SYMFDR(J,L,I,K) = TMPFDR(ITMP) 3397 SYMFDR(J,L,K,I) = TMPFDR(ITMP) 3398C 3399 SYMFDR(K,I,J,L) = TMPFDR(ITMP) 3400 SYMFDR(K,I,L,J) = TMPFDR(ITMP) 3401 SYMFDR(K,J,I,L) = TMPFDR(ITMP) 3402 SYMFDR(K,J,L,I) = TMPFDR(ITMP) 3403 SYMFDR(K,L,I,J) = TMPFDR(ITMP) 3404 SYMFDR(K,L,J,I) = TMPFDR(ITMP) 3405C 3406 SYMFDR(L,I,J,K) = TMPFDR(ITMP) 3407 SYMFDR(L,I,K,J) = TMPFDR(ITMP) 3408 SYMFDR(L,J,I,K) = TMPFDR(ITMP) 3409 SYMFDR(L,J,K,I) = TMPFDR(ITMP) 3410 SYMFDR(L,K,I,J) = TMPFDR(ITMP) 3411 SYMFDR(L,K,J,I) = TMPFDR(ITMP) 3412 100 CONTINUE 3413C 3414C ************************************** 3415C *** Printing symmetric coordinates *** 3416C *** Cartesian if no symmetry *** 3417C ************************************** 3418C 3419 IF (.NOT.MINOUT) THEN 3420 CALL PRFDER(SYMFDR,NCOOR,NUMCOR,TEXT,LTXT,IPRINT) 3421 ELSE 3422 WRITE (LUPRI,'(A/)') 3423 * " Output of fourth derivative suppressed" 3424 ENDIF 3425C 3426C ************************************ 3427C *** Transformation to cartesian *** 3428C *** coordinates, and printing. *** 3429C ************************************ 3430C 3431 IF ((FCLASS(1:3).NE.'C1 ').AND.(TEXT(1:6).NE.'normal')) THEN 3432C 3433C *** Coordinate transformation. *** 3434C 3435 CALL TRAFDR(SYMCOR,SYMFDR,FDER,NUMCOR,NUMCOR,NCOOR,TEXT, 3436 & LTXT,IPRINT) 3437C 3438C *** Printing in cartesian coordinates. *** 3439C 3440 IF (.NOT.MINOUT) 3441 & CALL PRFDER(FDER,NCOOR,NUMCOR,'cartesian',9,IPRINT) 3442 ELSE 3443 CALL DCOPY(NCOOR**4,SYMFDR,1,FDER,1) 3444 END IF 3445C 3446 RETURN 3447 END 3448C 3449C /*Deck trafdr*/ 3450 SUBROUTINE TRAFDR(TRCOOR,CR1FDR,CR2FDR,NMCOR1,NMCOR2,NCOOR,TEXT, 3451 & LTXT,IPRINT) 3452C ********************************************************** 3453C *** Transforming quartic force field to another set of *** 3454C *** coordinates *** 3455C ********************************************************** 3456#include "implicit.h" 3457#include "priunit.h" 3458 CHARACTER*(*) TEXT 3459 DIMENSION CR1FDR(NCOOR,NCOOR,NCOOR,NCOOR), 3460 & CR2FDR(NCOOR,NCOOR,NCOOR,NCOOR), TRCOOR(NCOOR,NCOOR) 3461C 3462 KDIM = NCOOR**4 3463C 3464 CALL DZERO(CR2FDR,KDIM) 3465 DO 100 ICR1C4 = 1, NMCOR1 3466 DO 100 ICR1C3 = 1, NMCOR1 3467 DO 100 ICR1C2 = 1, NMCOR1 3468 DO 100 ICR1C1 = 1, NMCOR1 3469 DO 100 ICR2C1 = 1, NMCOR2 3470 CR2FDR(ICR2C1,ICR1C2,ICR1C3,ICR1C4) = 3471 & CR2FDR(ICR2C1,ICR1C2,ICR1C3,ICR1C4) 3472 & + TRCOOR(ICR2C1,ICR1C1)*CR1FDR(ICR1C1,ICR1C2,ICR1C3,ICR1C4) 3473 100 CONTINUE 3474C 3475 CALL DZERO(CR1FDR,KDIM) 3476 DO 200 ICR1C4 = 1, NMCOR1 3477 DO 200 ICR1C3 = 1, NMCOR1 3478 DO 200 ICR1C2 = 1, NMCOR1 3479 DO 200 ICR2C2 = 1, NMCOR2 3480 DO 200 ICR2C1 = 1, NMCOR2 3481 CR1FDR(ICR2C1,ICR2C2,ICR1C3,ICR1C4) = 3482 & CR1FDR(ICR2C1,ICR2C2,ICR1C3,ICR1C4) 3483 & + TRCOOR(ICR2C2,ICR1C2)*CR2FDR(ICR2C1,ICR1C2,ICR1C3,ICR1C4) 3484 200 CONTINUE 3485C 3486 CALL DZERO(CR2FDR,KDIM) 3487 DO 300 ICR1C4 = 1, NMCOR1 3488 DO 300 ICR1C3 = 1, NMCOR1 3489 DO 300 ICR2C3 = 1, NMCOR2 3490 DO 300 ICR2C2 = 1, NMCOR2 3491 DO 300 ICR2C1 = 1, NMCOR2 3492 CR2FDR(ICR2C1,ICR2C2,ICR2C3,ICR1C4) = 3493 & CR2FDR(ICR2C1,ICR2C2,ICR2C3,ICR1C4) 3494 & + TRCOOR(ICR2C3,ICR1C3)*CR1FDR(ICR2C1,ICR2C2,ICR1C3,ICR1C4) 3495 300 CONTINUE 3496C 3497 CALL DZERO(CR1FDR,KDIM) 3498 DO 400 ICR1C4 = 1, NMCOR1 3499 DO 400 ICR2C4 = 1, NMCOR2 3500 DO 400 ICR2C3 = 1, NMCOR2 3501 DO 400 ICR2C2 = 1, NMCOR2 3502 DO 400 ICR2C1 = 1, NMCOR2 3503 CR1FDR(ICR2C1,ICR2C2,ICR2C3,ICR2C4) = 3504 & CR1FDR(ICR2C1,ICR2C2,ICR2C3,ICR2C4) 3505 & + TRCOOR(ICR2C4,ICR1C4)*CR2FDR(ICR2C1,ICR2C2,ICR2C3,ICR1C4) 3506 400 CONTINUE 3507C 3508 CALL DCOPY(KDIM,CR1FDR,1,CR2FDR,1) 3509C 3510 IF (IPRINT .GT. 7) THEN 3511 CALL PRFDER(CR2FDR,NCOOR,NMCOR2,TEXT,LTXT,IPRINT) 3512 END IF 3513C 3514 RETURN 3515 END 3516C 3517C 3518 SUBROUTINE HARMAN(SYMCOR,TRAMAT,TMPHES,WORK,NCOOR,LWORK,IPRINT) 3519#include "implicit.h" 3520#include "priunit.h" 3521#include "mxcent.h" 3522C 3523 DIMENSION SYMCOR(NCOOR,NCOOR), 3524 & TMPHES(NCOOR,NCOOR), TRAMAT(NCOOR,NCOOR), 3525 & WORK(LWORK) 3526 3527 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 3528C 3529 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 3530C 3531C *** Transforming the hessian matrix to cartesian *** 3532C *** coordinates. *** 3533C (as we do not write HESMOL back with ABAWRIT_TAYMOL 3534C it is OK that we modify the content of HESMOL) 3535C 3536 CALL OTRTEN(HESMOL,SYMCOR,TMPHES,NCOOR,NCOOR,NCOOR,IPRINT,'N','T') 3537C 3538C *** Transforming the hessian matrix to dalton *** 3539C *** symmetry coordinates. *** 3540C 3541C *** Transformation matrix. *** 3542C 3543 ITYPE = 1 3544 KTEST = 1 3545 CALL TRACOR(TRAMAT,WORK(KTEST),ITYPE,NCOOR,IPRINT) 3546C 3547C *** Transformation. *** 3548C 3549 CALL OTRTEN(HESMOL,TRAMAT,TMPHES,NCOOR,NCOOR,NCOOR,IPRINT,'N','T') 3550 3551 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 3552C 3553C *** Run harmonic analysis. *** 3554C 3555 KSTART = 1 3556 CALL VIBCTL(WORK(1),LWORK) 3557C 3558 RETURN 3559 END 3560C 3561C 3562C /* Deck mknrmc */ 3563 SUBROUTINE MKNRMC(SYMCOR,CSTART,TRNCCR,TRAMSS,EIGNVL,EGNVCT, 3564 & HESMWT,TM1TMP,TM2TMP,AMASS,DKIN,HTESTM,FREQ, 3565 & RNNORM,CORTMP,WORK,ICRIRP,NATTYP,NMSYSP, 3566 & LWORK,IPRINT) 3567************************************************************ 3568*** Makes normal coordinates from the molecular hessian, *** 3569*** and writes out the harmonic frequencies according *** 3570*** general symmetry species. *** 3571************************************************************ 3572#include "implicit.h" 3573#include "priunit.h" 3574#include "mxcent.h" 3575#include "codata.h" 3576 PARAMETER (DMTHR = 2.0D-8, D0 = 0.0D0, D1 = 1.0D0) 3577#include "trkoor.h" 3578#include "nuclei.h" 3579#include "cbinum.h" 3580#include "numder.h" 3581#include "abainf.h" 3582#include "dummy.h" 3583 CHARACTER*6 TXT 3584 DIMENSION SYMCOR(NCOOR,NCOOR), EIGNVL(NCOOR), EGNVCT(NCOOR,NCOOR), 3585 & HESMWT(NCOOR*(NCOOR+1)/2), AMASS(NATOMS), CSTART(NCOOR), 3586 & DKIN(NCOOR), TM1TMP(NCOOR,NCOOR), TRAMSS(NCOOR), 3587 & TM2TMP(NCOOR,NCOOR), TRNCCR(NCOOR,NCOOR), 3588 & FREQ(NCOOR), HTESTM(NCOOR,NCOOR), RNNORM(NCOOR), 3589 & CORTMP(NCOOR), WORK(LWORK), ENORMN(NCOOR) 3590 DIMENSION ICRIRP(NCOOR,2), NATTYP(NATOMS), NMSYSP(NCOOR) 3591 INTEGER BEGIN 3592 3593 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 3594C 3595C *** Calculating center of mass, and mass of each center *** 3596C 3597 CALL DCOPY(NCOOR,CSTART,1,CORTMP,1) 3598 CALL CMMASS(CORTMP,AMASS,NATTYP,WORK,IPRINT) 3599C 3600C *** Diagonal sqrt(mass)^(-1/2) matrix *** 3601C 3602 DO 200 IC = 1, NCOOR 3603 DKIN(IC) = D1/SQRT(XFAMU*AMASS((IC+2)/3)) 3604 200 CONTINUE 3605C 3606C *** The (mass)^(-1/2) matrix for symmetry coordinates. *** 3607C 3608 DO 300 IC2 = 1, NCOOR 3609 DO 300 IC1 = 1, NCOOR 3610 TM1TMP(IC1,IC2) = DKIN(IC1)*SYMCOR(IC1,IC2) 3611 300 CONTINUE 3612C 3613C *** TM2TMP is the (mass)^(-1/2) matrix. *** 3614C 3615 KDIM = NCOOR**2 3616 CALL DZERO(TM2TMP,KDIM) 3617 DO 400 IC3 = 1, NCOOR 3618 DO 400 IC2 = 1, NCOOR 3619 DO 400 IC1 = 1, NCOOR 3620 TM2TMP(IC1,IC3) = TM2TMP(IC1,IC3) 3621 & + SYMCOR(IC2,IC1)*TM1TMP(IC2,IC3) 3622 400 CONTINUE 3623C 3624C *** Test if TM2TMP is a diagonal matrix (if there are *** 3625C *** different isotopes) *** 3626C 3627 IF (HTEST) THEN 3628 DO 500 IC2 = 1, NCOOR 3629 DO 500 IC1 = 1, NCOOR 3630 IF ((IC1 .NE. IC2).AND.(ABS(TM2TMP(IC1,IC2)).GT.DMTHR)) 3631 & CALL QUIT('Diagonal mass test failed. Off-diagonal' // 3632 & 'elements present.') 3633 500 CONTINUE 3634 END IF 3635C 3636C *** Mass transformation matrix *** 3637C 3638 DO 600 IC = 1, NCOOR 3639 TRAMSS(IC) = D1/TM2TMP(IC,IC) 3640 600 CONTINUE 3641C 3642C *** Calculating the mass-weighted Hessian *** 3643C 3644 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 3645 CALL DZERO(TM1TMP,KDIM) 3646 DO 700 IC3 = 1, NCOOR 3647 DO 700 IC2 = 1, NCOOR 3648 DO 700 IC1 = 1, NCOOR 3649 TM1TMP(IC1,IC3) = TM1TMP(IC1,IC3) 3650 & + TM2TMP(IC1,IC2)*HESMOL(IC2,IC3) 3651 700 CONTINUE 3652C 3653C *** HESMWT is the mass-weighted hessian. *** 3654C 3655 IC12 = 0 3656 CALL DZERO(HESMWT,NCOOR*(NCOOR+1)/2) 3657 DO 800 IC2 = 1, NCOOR 3658 DO 800 IC1 = 1, IC2 3659 IC12 = IC12 + 1 3660 HESMWT(IC12) = HESMWT(IC12) + TM1TMP(IC1,IC2)*TM2TMP(IC2,IC2) 3661 800 CONTINUE 3662C 3663C *** Test to check if mass-weighted hessian is symmetric. *** 3664C 3665 IF (HTEST) THEN 3666 CALL DZERO(HTESTM,KDIM) 3667 DO 900 IC3 = 1, NCOOR 3668 DO 900 IC2 = 1, NCOOR 3669 DO 900 IC1 = 1, NCOOR 3670 HTESTM(IC1,IC3) = HTESTM(IC1,IC3) 3671 & + TM1TMP(IC1,IC2)*TM2TMP(IC2,IC3) 3672 900 CONTINUE 3673C 3674 IF (.NOT. RESTRT) THEN 3675 DO 1100 IC2 = 1, NCOOR 3676 DO 1100 IC1 = 1, IC2 3677 IF (ABS(HTESTM(IC1,IC2)-HTESTM(IC2,IC1)).GT.DMTHR) 3678 & CALL QUIT('Mass-weighted hessian is not symmetric.') 3679 1100 CONTINUE 3680 END IF 3681C 3682 CALL HEADER('Mass weighted Hessian in symmetry coordinates',-1) 3683 NUMTIM = (NCOOR-1)/6 + 1 3684 DO 1200 ITIM = 1, NUMTIM 3685 ISTART = 6*(ITIM-1) + 1 3686 IEND = MIN(6* ITIM ,NCOOR) 3687 DO 1300 IC1 = 1, NCOOR 3688 WRITE(LUPRI,'(6F17.14)')(HTESTM(IC1,IC2),IC2=ISTART,IEND) 3689 1300 CONTINUE 3690 WRITE (LUPRI,'(A)') ' ' 3691 1200 CONTINUE 3692 END IF 3693C 3694C *** Diagonalizing the mass weighted Hessian. *** 3695C 3696 KWRK = 1 3697 KIWRK = KWRK + NCOOR 3698 CALL DZERO(EGNVCT,NCOOR**2) 3699 CALL DUNIT(EGNVCT,NCOOR) 3700 CALL JACO(HESMWT,EGNVCT,NCOOR,NCOOR,NCOOR,WORK(KWRK),WORK(KIWRK)) 3701 3702C 3703C *** Storing the transformation matrix for later isotope-studies. **** 3704C 3705 DO 1400 IC2 = 1, NCOOR 3706 DO 1400 IC1 = 1, NCOOR 3707 TRNCCR(IC1,IC2) = EGNVCT(IC1,IC2) 3708 1400 CONTINUE 3709C 3710C *** Mass-weighting the normal coordinates. *** 3711C 3712 KDIM = NCOOR**2 3713 CALL DCOPY(KDIM,EGNVCT,1,TM1TMP,1) 3714 CALL DZERO(EGNVCT,KDIM) 3715 DO 1500 IC3 = 1, NCOOR 3716 DO 1500 IC2 = 1, NCOOR 3717 DO 1500 IC1 = 1, NCOOR 3718 EGNVCT(IC1,IC3) = EGNVCT(IC1,IC3) 3719 & + TM2TMP(IC1,IC2)*TM1TMP(IC2,IC3) 3720 1500 CONTINUE 3721C 3722C *** Normalizing the normal and transformation coordinates. *** 3723C 3724 CALL DZERO(RNNORM,NCOOR) 3725 DO 1600 IC2 = 1, NCOOR 3726 RLENGT2 = D0 3727 DO 1700 IC1 = 1, NCOOR 3728 RNNORM(IC2) = RNNORM(IC2) + EGNVCT(IC1,IC2)**2 3729 RLENGT2 = RLENGT2 + TRNCCR(IC1,IC2)**2 3730 1700 CONTINUE 3731 RNNORM(IC2) = SQRT(RNNORM(IC2)) 3732C 3733 DRINV1 = D1/RNNORM(IC2) 3734 DRINV2 = D1/SQRT(RLENGT2) 3735 DO 1800 IC1 = 1, NCOOR 3736 EGNVCT(IC1,IC2) = EGNVCT(IC1,IC2)*DRINV1 3737 TRNCCR(IC1,IC2) = TRNCCR(IC1,IC2)*DRINV2 3738 1800 CONTINUE 3739 1600 CONTINUE 3740C 3741C *** Removing the redundant normal coordinates, and setting some *** 3742C *** common variables according to this *** 3743C 3744 IC12 = 0 3745 IFREQ = 0 3746 NUMZRO = 0 3747 DO 1900 IC = 1, NCOOR 3748 IC12 = IC12 + IC 3749 IF (ABS(HESMWT(IC12)).GT.DMTHR) THEN 3750 IFREQ = IFREQ + 1 3751 FREQ(IFREQ) = SQRT(ABS(HESMWT(IC12))) 3752 ELSE 3753 NUMZRO = NUMZRO + 1 3754 DO 2100 IC2 = IC-NUMZRO+1, NCOOR-1 3755 ICRIRP(IC2,1) = ICRIRP(IC2+1,1) 3756 ICRIRP(IC2,2) = ICRIRP(IC2+1,2) 3757 DO 2200 IC1 = 1, NCOOR 3758 RNNORM( IC2) = RNNORM( IC2+1) 3759 EGNVCT(IC1,IC2) = EGNVCT(IC1,IC2+1) 3760 TRNCCR(IC1,IC2) = TRNCCR(IC1,IC2+1) 3761 2200 CONTINUE 3762C 3763 2100 CONTINUE 3764C 3765 END IF 3766 1900 CONTINUE 3767 NDCOOR = NCOOR - NUMZRO 3768C 3769C *** Calculating the normal coordinates in cartesian coordinates *** 3770C 3771 CALL DZERO(TM1TMP,KDIM) 3772 DO 2300 IC3 = 1, NCOOR-NUMZRO 3773 DO 2300 IC2 = 1, NCOOR 3774 DO 2300 IC1 = 1, NCOOR 3775 TM1TMP(IC1,IC3) = TM1TMP(IC1,IC3) 3776 & + SYMCOR(IC1,IC2)*EGNVCT(IC2,IC3) 3777 2300 CONTINUE 3778C 3779C *** Using these coordinates in future differentiations. *** 3780C 3781 DO 2400 IC2 = 1, NCOOR-NUMZRO 3782 DO 2400 IC1 = 1, NCOOR 3783 SYMCOR(IC1,IC2) = TM1TMP(IC1,IC2) 3784 2400 CONTINUE 3785C 3786C *** Printing the frequencies. *** 3787C 3788 WRITE (LUPRI, '(10X,A,I3)') 3789 & 'Number of modes with zero frequency: ', NUMZRO 3790 CALL HEADER('Vibrational frequencies harmonic approximation: ',-1) 3791 WRITE (LUPRI,'(20X,A)') ' Mode cm-1 hartrees ' 3792 DO 2500 IFREQ = 1, NCOOR-NUMZRO 3793 WRITE (LUPRI,'(20X,I4,F12.2,F12.6)') ICRIRP(IFREQ,1), 3794 & XTKAYS*FREQ(IFREQ), FREQ(IFREQ) 3795 2500 CONTINUE 3796C 3797C *** Printing the cartesian components of the normal coordinates *** 3798C 3799 NONZRO = NCOOR-NUMZRO 3800 CALL HEADER('Normal coordinates: ',0) 3801 NUMTIM = (NONZRO-1)/6 + 1 3802 DO ITIM = 1, NUMTIM 3803 ISTART = 6*(ITIM-1)+1 3804 IEND = MIN(6*ITIM,NONZRO) 3805 WRITE (LUPRI,'(I11,8I13)') (ICRIRP(I,1),I=ISTART,IEND) 3806 DO ICOOR = 1, NCOOR 3807 WRITE (LUPRI,'(6F13.7)') (SYMCOR(ICOOR,I),I=ISTART,IEND) 3808 END DO 3809 WRITE (LUPRI,'(A)') ' ' 3810 END DO 3811 3812C We punch out harmonic freqs and normal coordinates on file 3813C DALTON.NOR for use in Midas Vibrational calculations 3814 3815 LUNOR = -1 3816 CALL GPOPEN(LUNOR,'DALTON.NOR','UNKNOWN',' ','FORMATTED',IDUMMY, 3817 & .FALSE.) 3818 WRITE(LUNOR,'(A)') 'Harmonic Freqs. in cm^-1' 3819 DO 911 IMODE = 1, NONZRO 3820 WRITE(LUNOR,'(1P,E23.16)') XTKAYS*FREQ(IMODE) 3821 911 CONTINUE 3822 WRITE(LUNOR,*) 3823 3824 3825C The normal coordinates in SYMCOR is normalized to one in cartesian (x) space. We 3826C would like the normal coordinates to be normalized to one in q-space, q = sqrt(m)*x 3827 3828 DO 912 IMODE = 1,NONZRO 3829 ENORM2 = 0.0D0 3830 DO 913 I = 1, NCOOR 3831 ENORM2 = ENORM2 + (SYMCOR(I,IMODE)**2)/(DKIN(I)*DKIN(I)*XFAMU) 3832 913 CONTINUE 3833 ENORMN(IMODE) = D1/SQRT(ENORM2) 3834 912 CONTINUE 3835 3836 WRITE(LUNOR,'(A)') 'Normal Coordinates' 3837 DO 914 IMODE = 1, NONZRO 3838 WRITE(LUNOR,8041) (ENORMN(IMODE)*SYMCOR(I,IMODE),I=1,NCOOR) 3839 WRITE(LUNOR,*) 3840 914 CONTINUE 3841 3842 WRITE(LUNOR,'(A)') 'Norm of Vectors' 3843 DO 915 IMODE = 1, NONZRO 3844 ENORM2 = 0.0D0 3845 DO 916 I = 1, NCOOR 3846 ENORM2 = ENORM2 + (ENORMN(IMODE)*SYMCOR(I,IMODE))**2 3847 916 CONTINUE 3848 WRITE(LUNOR,'(1P,E23.16)') SQRT(ENORM2) 3849 915 CONTINUE 3850 3851 CALL GPCLOSE(LUNOR,'KEEP') 3852 3853C 3854C *** Writing to spectro file if requested. *** 3855C 3856 IF (SPECTR) THEN 3857 NTIME = 1 3858 IF (NRMCRD) THEN 3859 TXT = 'normal' 3860 ELSE 3861 TXT = 'cartes' 3862 END IF 3863 CALL WRISPC(FREQ,RNNORM,VDUMMY,VDUMMY,TXT,NCOOR,NDCOOR,NTIME, 3864 & IPRINT) 3865 END IF 3866 IF (MIDAS) THEN 3867 NTIME = 1 3868 IF (NRMCRD) THEN 3869 TXT = 'normal' 3870 ELSE 3871 TXT = 'cartes' 3872 END IF 3873 IF (NRMCRD) CALL WRIMOP(FREQ,RNNORM,VDUMMY,VDUMMY,TXT,NCOOR, 3874 & NDCOOR,NTIME,IPRINT) 3875 END IF 3876C 3877C *** Test printing. *** 3878C 3879 IF (IPRINT .GE. 20) THEN 3880 CALL HEADER('Eigenvectors of the symmetry adapted hessian',-1) 3881 DO IC1 = 1, NCOOR 3882 WRITE (LUPRI,'(10X,12F9.4)') (EGNVCT(IC1,IC2),IC2=1,NCOOR) 3883 END DO 3884C 3885 CALL HEADER ('Atomic masses used',-1) 3886 WRITE (LUPRI,'(3X,A,10I9)') 'Atom number:', (I,I=1,NATOMS) 3887 WRITE (LUPRI,'(17X, 10F9.4 )') (AMASS(I), I = 1, NATOMS) 3888C 3889 CALL HEADER('Diagonal elements of (sqrt(mass))^-1 matrix',-1) 3890 WRITE (LUPRI,'(24F9.4)') (DKIN(IC), IC=1,NCOOR) 3891C 3892 CALL HEADER('Transformed sqrt(mass)^-1 matrix',-1) 3893 DO IC1 = 1, NCOOR 3894 WRITE (LUPRI,'(24F10.7)') (TM2TMP(IC1,IC2),IC2= 1, NCOOR) 3895 END DO 3896C 3897C *** Mass-weighted hessian. *** 3898C 3899 CALL HEADER('Diagonalized mass weighted hessian.',-1) 3900C 3901 IJ = 0 3902 DO J = 1, NCOOR 3903 DO I = 1, J 3904 IJ = IJ + 1 3905 TM2TMP(I,J) = HESMWT(IJ) 3906 TM2TMP(J,I) = HESMWT(IJ) 3907 END DO 3908 END DO 3909C 3910 BEGIN = 1 3911 KCOL = 9 3912 LAST = MIN(NCOOR,KCOL) 3913 NCOL = NCOOR/KCOL 3914 IF (MOD(NCOOR,KCOL).NE.0) NCOL = NCOL + 1 3915C 3916 DO ICOL = 1, NCOL 3917 WRITE (LUPRI,1000) (ICRIRP(I,1),I = BEGIN,LAST) 3918C 3919 DO ICOOR = BEGIN, NCOOR 3920 WRITE (LUPRI,2000) ICRIRP(ICOOR,1), 3921 & (TM2TMP(ICOOR,I),I=BEGIN,MIN(LAST,ICOOR)) 3922 END DO 3923 WRITE (LUPRI,'()') 3924 BEGIN = BEGIN + KCOL 3925 LAST = MIN(NCOOR,KCOL+LAST) 3926 END DO 3927 1000 FORMAT (8X,6(3X,I4,5X),(3X,I4,5X)) 3928 2000 FORMAT (1X,I4,2X,9F12.6) 3929 8041 FORMAT(1P,3E23.16) 3930 END IF 3931C 3932 RETURN 3933 END 3934C 3935C 3936C /*Deck trafrc*/ 3937 SUBROUTINE TRAFRC(TDER,FDER,HESNRM,CORNRM,CRTNRM,SYCART,TNRMDR, 3938 & FNRMDR,WORK,NCOOR,NDIMF,NDIMT,LWORK,IPRINT) 3939#include "implicit.h" 3940#include "mxcent.h" 3941#include "priunit.h" 3942#include "maxorb.h" 3943C 3944#include "infpar.h" 3945#include "numder.h" 3946#include "cbinum.h" 3947 CHARACTER*80 TEXT 3948 LOGICAL PRWHLE 3949 DIMENSION FDER(NDIMF), TDER(NDIMT), HESNRM(NCOOR,NCOOR), 3950 & CORNRM(NCOOR,NCOOR), CRTNRM(NCOOR,NCOOR), 3951 & SYCART(NCOOR,NCOOR), TNRMDR(NCOOR,NCOOR,NCOOR), 3952 & FNRMDR(NCOOR,NCOOR,NCOOR,NCOOR), WORK(LWORK) 3953 3954 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 3955C 3956C *** Transformation of hessians. *** 3957C 3958 IF (NAORDR+NMORDR.GE.2) THEN 3959 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 3960 DO 100 J = 1, NCOOR 3961 DO 100 I = 1, J 3962 HESNRM(I,J) = HESMOL(I,J) 3963 HESNRM(J,I) = HESMOL(I,J) 3964 100 CONTINUE 3965C 3966C *** Transforming hessian to cartesian coordinates. *** 3967C 3968 KTMPHS = 1 3969 CALL OTRTEN(HESNRM,SYCART,WORK(KTMPHS),NCOOR,NCOOR,NCOOR, 3970 & IPRINT,'N','T') 3971C 3972C *** Then to normal coordinates. *** 3973C 3974 CALL OTRTEN(HESNRM,CORNRM,WORK(KTMPHS),NCOOR,NCOOR,NDCOOR, 3975 & IPRINT,'T','N') 3976C 3977C *** Printing hessian. *** 3978C 3979 CALL HEADER('Hessian in normal coordinates',-1) 3980 CALL PRTRMA(HESNRM,NCOOR,NCOOR,NDCOOR,NDCOOR,LUPRI) 3981 END IF 3982C 3983C *** Setting up the transformation (cartesian -> normal) *** 3984C *** matrix needed for cubic and quartic force fields. *** 3985C 3986 IF (NAORDR+NMORDR.GE.3) THEN 3987 DO 200 J = 1, NCOOR 3988 DO 200 I = 1, NCOOR 3989 CRTNRM(I,J) = CORNRM(J,I) 3990 200 CONTINUE 3991 END IF 3992C 3993C *** Transformation of cubic force field. *** 3994C 3995 IF (NAORDR+NMORDR.GE.3) THEN 3996C 3997C *** Transformation to cartesian coordinates and *** 3998C *** printing. Force field is returned in TNRMDR. *** 3999C 4000 PRWHLE = .TRUE. 4001 KSYMTD = 1 4002 LTXT = 8 4003 TEXT(1:8) = 'Symmetry' 4004 CALL PRITDR(TDER,SYCART,TNRMDR,WORK(KSYMTD),NDIMT,NCOOR,LTXT, 4005 & IPRINT,PRWHLE,TEXT) 4006C 4007C *** Transforming to normal coordinates. *** 4008C 4009 LTXT = 6 4010 TEXT(1:6) = 'normal' 4011C 4012 KTMPTD = 1 4013 CALL DCOPY(NCOOR**3,TNRMDR,1,WORK(KTMPTD),1) 4014 CALL TRATDR(CRTNRM,WORK(KTMPTD),TNRMDR,NCOOR,NDCOOR,NCOOR, 4015 & TEXT,LTXT,IPRINT) 4016C 4017 IF (.NOT.MINOUT) 4018 & CALL PRTDER(TNRMDR,NCOOR,NDCOOR,TEXT,LTXT,IPRINT) 4019 END IF 4020C 4021C *** Transformation of quartic force field. *** 4022C 4023 IF (NAORDR+NMORDR.GE.4) THEN 4024C 4025C *** Transformation to cartesian coordinates and *** 4026C *** printing. Force field is returned in FNRMDR. *** 4027C 4028 KSYMTD = 1 4029 LTXT = 8 4030 TEXT(1:8) = 'Symmetry' 4031 CALL PRIFDR(FDER,SYCART,FNRMDR,WORK(KSYMTD),NDIMF,NCOOR,LTXT, 4032 & IPRINT,TEXT) 4033C 4034C *** Transforming to normal coordinates. *** 4035C 4036 LTXT = 6 4037 TEXT(1:6) = 'normal' 4038C 4039 KTMPFD = 1 4040 CALL DCOPY(NCOOR**4,FNRMDR,1,WORK(KTMPFD),1) 4041 CALL TRAFDR(CRTNRM,WORK(KTMPFD),FNRMDR,NCOOR,NDCOOR,NCOOR, 4042 & TEXT,LTXT,IPRINT) 4043C 4044C *** Printing. *** 4045C 4046 IF (.NOT.MINOUT) 4047 & CALL PRFDER(FNRMDR,NCOOR,NDCOOR,TEXT,LTXT,IPRINT) 4048 END IF 4049C 4050 RETURN 4051 END 4052C 4053C 4054C /* Deck prtder*/ 4055 SUBROUTINE PRTDER(TDER,NDIM,NCOR,TEXT,LTXT,IPRINT) 4056C ********************************************************** 4057C *** Printing of third derivatives in TEXT coordinates. *** 4058C ********************************************************** 4059#include "implicit.h" 4060#include "priunit.h" 4061 CHARACTER*(*) TEXT 4062 DIMENSION TDER(NDIM,NDIM,NDIM) 4063 4064C 4065C *** Header print. *** 4066C 4067 CALL HEADER('Third derivative of energy in ' // TEXT(1:LTXT) 4068 & // ' coordinates',-1) 4069C 4070C *** Printing of force field. *** 4071C 4072 IF (MOD(NCOR,6).EQ.0) THEN 4073 NLCMAX = NCOR/6 4074 ELSE 4075 NLCMAX = INT(NCOR/6)+1 4076 END IF 4077C 4078 DO 100 ICOL2 = 1, NCOR 4079 WRITE (LUPRI,'(A,I5)') ' Column number', ICOL2 4080 WRITE (LUPRI,'(A)') ' ------------------' 4081 INLC = 0 4082 DO 200 INLCMX = 1, NLCMAX 4083 INLC2 = 6*(INLCMX-1) + 1 4084 INLC = MIN(INLC+6,NCOR) 4085 DO 300 ICOL1 = 1, NCOR 4086 WRITE (LUPRI,'(A,6F10.6)') ' ', 4087 & (TDER(I,ICOL1,ICOL2), I=INLC2, INLC) 4088 300 CONTINUE 4089 WRITE (LUPRI,'()') 4090 200 CONTINUE 4091 100 CONTINUE 4092C 4093 RETURN 4094 END 4095C 4096C 4097C /* Deck prfder*/ 4098 SUBROUTINE PRFDER(FDER,NDIM,NCOR,TEXT,LTXT,IPRINT) 4099C ********************************************************** 4100C *** Printing of fourth derivative in TEXT coordinates. *** 4101C ********************************************************** 4102#include "implicit.h" 4103#include "priunit.h" 4104 CHARACTER*(*) TEXT 4105 DIMENSION FDER(NDIM,NDIM,NDIM,NDIM) 4106C 4107C *** Header print. *** 4108C 4109 CALL HEADER('Fourth derivative of energy in ' // TEXT(1:LTXT) 4110 & // ' coordinates',-1) 4111C 4112C *** Printing of derivative. *** 4113C 4114 IF (MOD(NCOR,6).EQ.0) THEN 4115 NLCMAX = NCOR/6 4116 ELSE 4117 NLCMAX = INT(NCOR/6)+1 4118 END IF 4119C 4120 DO 100 ICOL3 = 1, NCOR 4121 WRITE (LUPRI,'(A,I4)') ' The fourth dimension', ICOL3 4122 WRITE (LUPRI,'(A/)') ' ------------------------' 4123 DO 200 ICOL2 = 1, NCOR 4124 WRITE (LUPRI,'(A,I4)') ' The third Dimension', ICOL2 4125 INLC = 0 4126 DO 300 INLCMX = 1, NLCMAX 4127 INLC2 = 6*(INLCMX-1) + 1 4128 INLC = MIN(INLC+6,NCOR) 4129 DO 400 ICOL1 = 1, NCOR 4130 WRITE (LUPRI,'(A,6F10.6)') ' ', 4131 & (FDER(I,ICOL1,ICOL2,ICOL3), I=INLC2, INLC) 4132 400 CONTINUE 4133 WRITE (LUPRI,'()') 4134 300 CONTINUE 4135 200 CONTINUE 4136 100 CONTINUE 4137C 4138 RETURN 4139 END 4140C 4141C 4142C /*Deck prderv*/ 4143 SUBROUTINE PRDERV(TDER,FDER,TSTGDR,TSTSDR,SYMCOR,CSTART,TTMPDR, 4144 & FTMPDR,RNNORM,WORK,ICRIRP,LWORK,NPRRDR,NDIMT, 4145 & NDIMF,LTXT,IPRINT,TEXT) 4146C *************************************************************** 4147C **** This routine prints out the derivatives of the energy **** 4148C **** to NPRRDR order. These are done in 'TEXT' coordinates **** 4149C *************************************************************** 4150#include "implicit.h" 4151#include "mxcent.h" 4152#include "priunit.h" 4153#include "maxorb.h" 4154#include "maxaqn.h" 4155#include "dummy.h" 4156C 4157#include "symmet.h" 4158#include "nuclei.h" 4159#include "trkoor.h" 4160#include "cbiwlk.h" 4161#include "cbinum.h" 4162#include "numder.h" 4163#include "pvibav.h" 4164 LOGICAL CPRPBK, PRWHLE 4165 CHARACTER*(*) TEXT 4166 DIMENSION TDER(NDIMT), FDER(NDIMF), TSTGDR(NCOOR), CSTART(NCOOR), 4167 & TSTSDR(NCOOR,NCOOR), SYMCOR(NCOOR,NCOOR), 4168 & TTMPDR(NCOOR,NCOOR,NCOOR), 4169 & RNNORM(NCOOR), 4170 & FTMPDR(NCOOR,NCOOR,NCOOR,NCOOR), WORK(LWORK) 4171 DIMENSION ICRIRP(NCOOR,2) 4172 4173 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 4174C 4175C *** We are finished calculating properties. But are *** 4176C *** backing it up for later use. *** 4177C 4178 CPRPBK = CNMPRP 4179 CNMPRP = .FALSE. 4180C 4181C *** Print gradient *** 4182C 4183 IF (NPRRDR.GT.0) THEN 4184C 4185 IF (NAORDR.LT.1) THEN 4186 CALL HEADER('Numerical gradient in ' // TEXT(1:LTXT) // 4187 & ' coordinates',-1) 4188 ELSE 4189 CALL HEADER('Analytical gradient in ' // TEXT(1:LTXT) // 4190 & ' coordinates',-1) 4191 KCSTRA = 1 4192 KSCTRA = KCSTRA + NCOOR**2 4193 KEGRAD = KSCTRA + NCOOR**2 4194 KSEGRD = KEGRAD + MXCOOR 4195 KLAST = KSEGRD + NCOOR 4196 LWRK1 = LWORK - KLAST + 1 4197 IF (KLAST.GT.LWORK) CALL QUIT('Memory exceeded in TRFCGD') 4198 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4199 CALL TRAGRD(GRDMOL,WORK(KEGRAD),WORK(KCSTRA),WORK(KSCTRA), 4200 & NCRREP(0,1),NCOOR) 4201 CALL TRFCGD(WORK(KEGRAD),SYMCOR,CSTART,WORK(KSEGRD), 4202 & WORK(KLAST),NCOOR,NDCOOR,LWRK1,IPRINT) 4203 CALL DCOPY(NCOOR,WORK(KEGRAD),1,GRDMOL,1) 4204 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4205 END IF 4206C 4207 KCGRAD = 1 4208 KWRK = KCGRAD + MXCOOR 4209 LWRK = LWORK - KWRK 4210 LNEED = 2*MXCOOR*MXCOOR 4211 IF ((LWRK - LNEED) .LT. 0) 4212 & CALL STOPIT('PRDERV','GSPGRD',LWRK,LNEED) 4213 CALL GSPGRD(SYMCOR,WORK(KCGRAD),WORK(KWRK),LWRK,ICRIRP,LTXT, 4214 & IPRINT,TEXT) 4215C 4216C *** If comparing with the analytical gradient. *** 4217C 4218 IF (SDRTST) THEN 4219 DO 200 IC1 = 1, NCOOR 4220 TSTGDR(IC1) = WORK(KCGRAD-1+IC1) 4221 200 CONTINUE 4222 END IF 4223 END IF 4224C 4225C *** Print hessian *** 4226C 4227 IF (NPRRDR.GT.1) THEN 4228C 4229 IF (PREHES) THEN 4230 CALL HEADER('Precalculated hessian in ' // TEXT(1:LTXT) // 4231 & ' coordinates',-1) 4232 ELSE IF (NAORDR .GE. 2) THEN 4233 CALL HEADER('Analytical hessian in ' // TEXT(1:LTXT) // 4234 & ' coordinates',-1) 4235 ELSE 4236 CALL HEADER('Numerical hessian in ' // TEXT(1:LTXT) // 4237 & ' coordinates',-1) 4238 END IF 4239C 4240 IF ((NAORDR.GE.2).AND..NOT.PREHES) THEN 4241 KCSTRA = 1 4242 KSCTRA = KCSTRA + NCOOR**2 4243 KEHESS = KSCTRA + NCOOR**2 4244 KSEHSS = KEHESS + MXCOOR**2 4245 KLAST = KSEHSS + NCOOR**2 4246 LWRK1 = LWORK - KLAST + 1 4247 IF (KLAST.GT.LWORK) CALL QUIT('Memory exceeded in TRFCHS') 4248 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4249 CALL TRAHES(HESMOL,NCOOR,WORK(KEHESS),WORK(KCSTRA), 4250 & WORK(KSCTRA),MXCOOR,NCOOR,1) 4251 CALL TRFCHS(WORK(KEHESS),SYMCOR,CSTART,WORK(KSEHSS), 4252 & WORK(KLAST),NCOOR,NDCOOR,LWRK1,IPRINT) 4253 4254 CALL MCOPY(NCOOR,NCOOR,WORK(KEHESS),MXCOOR,HESMOL,NCOOR) 4255! CALL MCOPY(NROWA,NCOLA,A,NRDIMA,B,NRDIMB) 4256 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4257 END IF 4258C 4259 KSMCIN = 1 4260 KCHES1 = KSMCIN + NCOOR**2 4261 KCHES2 = KCHES1 + NCOOR**2 4262 KLAST = KCHES2 + NCOOR**2 4263 LWRK = LWORK - KLAST 4264 CALL GSPHES(SYMCOR,WORK(KSMCIN),WORK(KCHES1),WORK(KCHES2), 4265 & WORK(KLAST),ICRIRP,NDCOOR,LWRK,LTXT,IPRINT,TEXT) 4266C 4267C *** If comparing with the analytical hessian. *** 4268C 4269 IF (SDRTST) THEN 4270 IC12 = 0 4271 DO 300 IC2 = 1, NCOOR 4272 DO 300 IC1 = 1, NCOOR 4273 IC12 = IC12 + 1 4274 TSTSDR(IC1,IC2) = WORK(KCHES2-1+IC12) 4275 300 CONTINUE 4276 END IF 4277 END IF 4278C 4279C *** Print third derivative of energy *** 4280C 4281 IF (NPRRDR.GT.2) THEN 4282C 4283 PRWHLE = .NOT.(ANALZ1.AND.NRMCRD.AND.((NMORDR+NAORDR).EQ.3)) 4284C 4285 KTDER = 1 4286 KSYMTD = KTDER + NCOOR**3 4287 KLAST = KSYMTD + NCOOR**3 4288 CALL HEADER('Numerical third derivative of energy in ' // 4289 & TEXT(1:LTXT) // ' coordinates',-1) 4290 CALL PRITDR(TDER,SYMCOR,TTMPDR,WORK(KSYMTD),NDIMT,NDCOOR,LTXT, 4291 & IPRINT,PRWHLE,TEXT) 4292 END IF 4293C 4294C *** Print fourth derivative of energy *** 4295C 4296 IF (NPRRDR.GT.3) THEN 4297 KFDER = 1 4298 KSYMFD = KFDER + NCOOR**4 4299 KSCTRA = KSYMFD + NCOOR**4 4300 KCSTRA = KSCTRA + NCOOR**2 4301 KLAST = KCSTRA + NCOOR**2 4302 CALL HEADER('Numerical fourth derivative of energy in ' // 4303 & TEXT(1:LTXT) // ' coordinates',-1) 4304 CALL PRIFDR(FDER,SYMCOR,FTMPDR,WORK(KSYMFD),NDIMF,NDCOOR,LTXT, 4305 & IPRINT,TEXT) 4306 END IF 4307C 4308C *** Writing to spectro file if requested. *** 4309C 4310 IF (SPECTR) THEN 4311 NTIME = 2 4312 CALL WRISPC(VDUMMY,VDUMMY,TTMPDR,FTMPDR,TEXT(1:6),NCOOR,NDCOOR, 4313 & NTIME,IPRINT) 4314 END IF 4315 IF (MIDAS) THEN 4316 NTIME = 2 4317 CALL WRIMOP(VDUMMY,RNNORM,TTMPDR,FTMPDR,TEXT(1:6),NCOOR,NDCOOR, 4318 & NTIME,IPRINT) 4319 END IF 4320C 4321 IF ((IPRINT .GT. 20).AND.(NPRRDR.EQ.2)) THEN 4322 CALL HEADER ('Copy of Hessian for test',-1) 4323 DO IC1 = 1, NCOOR 4324 WRITE (LUPRI,'(12F12.8)') (TSTSDR(IC1,IC2),IC2=1,NCOOR) 4325 END DO 4326 END IF 4327C 4328C *** Restoring CNMPRP. *** 4329C 4330 CNMPRP = CPRPBK 4331C 4332 RETURN 4333 END 4334C 4335C 4336C 4337C /*Deck gspgrd*/ 4338 SUBROUTINE GSPGRD(SYMCOR,CGRAD,WORK,LWORK,ICRIRP,LTXT,IPRINT,TEXT) 4339#include "implicit.h" 4340#include "mxcent.h" 4341#include "maxaqn.h" 4342#include "maxorb.h" 4343#include "priunit.h" 4344C 4345#include "symmet.h" 4346#include "nuclei.h" 4347#include "trkoor.h" 4348#include "cbiwlk.h" 4349#include "numder.h" 4350 CHARACTER TEXT*(*) 4351 DIMENSION SYMCOR(NCOOR,NCOOR), CGRAD(NCOOR), ICRIRP(NCOOR,2), 4352 & WORK(LWORK) 4353 4354 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 4355C 4356 CALL HEADER('Gradient in ' // TEXT(1:LTXT) // ' coordinates',-1) 4357C 4358 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4359 DO 100 ICOOR = 1, NDCOOR 4360 IF (ICRIRP(ICOOR,1).EQ.1) THEN 4361 WRITE (LUPRI,'(F47.8)') GRDMOL(ICOOR) 4362 END IF 4363 100 CONTINUE 4364C 4365 CALL DZERO(CGRAD,NCOOR) 4366 DO 200 ICOOR2 = 1, NDCOOR 4367 DO 200 ICOOR1 = 1, NCOOR 4368 CGRAD(ICOOR1) = CGRAD(ICOOR1) 4369 & + SYMCOR(ICOOR1,ICOOR2)*GRDMOL(ICOOR2) 4370 200 CONTINUE 4371C 4372 CALL HEADER('Gradient in cartesian coordinates',-1) 4373C 4374 IOFF = 0 4375 DO 300 ICENT = 1, NUCDEP 4376 WRITE (LUPRI,'(1X,A6,F17.10,2F24.10)') NAMDEP(ICENT), 4377 & (CGRAD(IOFF+J), J=1,3) 4378 IOFF = IOFF + 3 4379 300 CONTINUE 4380C 4381C *** Transform to symmetry basis used in Dalton in *** 4382C *** case of geometry optimization *** 4383C 4384 IF (MAXREP .GT. 0) THEN 4385 KCSTRA = 1 4386 KSCTRA = KCSTRA + MXCOOR*MXCOOR 4387 CALL TRACOR(WORK(KCSTRA),WORK(KSCTRA),1,MXCOOR,IPRINT) 4388 CALL TRACTS(CGRAD,3*NUCDEP,WORK(KCSTRA)) 4389 CALL DCOPY(3*NUCDEP,CGRAD,1,GRDMOL,1) 4390C 4391 CALL HEADER('Gradient in Dalton symmetry coordinates',-1) 4392C 4393 DO 202 I = 1, NCRREP(0,1) 4394 WRITE (LUPRI,'(25X,A6,F17.10)') NAMEX(IPTCOR(I,1)),GRDMOL(I) 4395 202 CONTINUE 4396 END IF 4397C 4398C *** If testing *** 4399C 4400 IF (SDRTST) THEN 4401 DO IC1 = 1, NCOOR 4402 GRDMOL(IC1) = CGRAD(IC1) 4403 END DO 4404 END IF 4405C 4406C *** Print *** 4407C 4408 IF (IPRINT .GT. 20) THEN 4409 CALL HEADER('Symcor matrix in GSPGRD',-1) 4410 DO 400 I = 1, NCOOR 4411 WRITE (LUPRI,'(24F12.7)') (SYMCOR(I,J),J=1,NCOOR) 4412 400 CONTINUE 4413 END IF 4414C 4415 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4416 RETURN 4417 END 4418C 4419C 4420C /*Deck gsphes*/ 4421 SUBROUTINE GSPHES(SYMCOR,SMCINV,CHESS1,CHESS2,WORK,ICRIRP, 4422 & NDCOOR,LWORK,LTXT,IPRINT,TEXT) 4423 use pelib_interface, only: use_pelib 4424#include "implicit.h" 4425#include "mxcent.h" 4426#include "priunit.h" 4427 PARAMETER (KCOL=6) 4428#include "nuclei.h" 4429#include "trkoor.h" 4430#include "cbiwlk.h" 4431#include "cbinum.h" 4432#include "gnrinf.h" 4433 INTEGER BEGIN, LAST 4434 LOGICAL HESEXS 4435 CHARACTER TEXT*(*) 4436 DIMENSION SYMCOR(NCOOR,NCOOR), SMCINV(NCOOR,NCOOR), 4437 & CHESS1(NCOOR,NCOOR), CHESS2(NCOOR,NCOOR), 4438 & WORK(LWORK), ICRIRP(NCOOR, 2) 4439 4440 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 4441C 4442C *** Print hessian in symmetry coordinates *** 4443C 4444 CALL HEADER('Hessian in ' // TEXT(1:LTXT) // ' coordinates',-1) 4445 WRITE(LUPRI,'(/8X,A/)') 'Notation: irrep/coordinate number' 4446 4447 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4448C 4449 BEGIN = 1 4450 LAST = MIN(NDCOOR,KCOL) 4451 KCOOR = NDCOOR 4452 NCOL = NDCOOR/KCOL 4453 IF (MOD(NDCOOR,KCOL).NE.0) NCOL = NCOL + 1 4454C 4455 DO 100 ICOL = 1, NCOL 4456 WRITE (LUPRI,1000) (ICRIRP(I,1),I,I = BEGIN,LAST) 4457C 4458 DO 200 ICOOR = BEGIN, NDCOOR 4459 WRITE (LUPRI,2000) ICRIRP(ICOOR,1),ICOOR, 4460 & (HESMOL(ICOOR,I),I=BEGIN,MIN(LAST,ICOOR)) 4461 200 CONTINUE 4462 WRITE (LUPRI,'()') 4463 BEGIN = BEGIN + KCOL 4464 LAST = MIN(NDCOOR,KCOL+LAST) 4465 100 CONTINUE 4466C 4467 DO 300 J = 1, NDCOOR 4468 DO 300 I = 1, J 4469 HESMOL(I,J) = HESMOL(J,I) 4470 300 CONTINUE 4471 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4472C 4473C *** Transpose of coordinate transformation matrix *** 4474C 4475 IF (TEXT(1:6) .NE. 'normal') THEN 4476 DO 350 J = 1, NDCOOR 4477 DO 350 I = 1, NCOOR 4478 SMCINV(J,I) = SYMCOR(I,J) 4479 350 CONTINUE 4480C 4481C *** Transform to cartesian hessian *** 4482C 4483 KDIM = NCOOR**2 4484 CALL DZERO(CHESS1,KDIM) 4485 DO 400 K = 1, NCOOR 4486 DO 400 J = 1, NDCOOR 4487 DO 400 I = 1, NDCOOR 4488 CHESS1(I,K) = CHESS1(I,K) + HESMOL(I,J)*SMCINV(J,K) 4489 400 CONTINUE 4490C 4491 KDIM = NCOOR**2 4492 CALL DZERO(CHESS2,KDIM) 4493 DO 500 K = 1, NCOOR 4494 DO 500 J = 1, NDCOOR 4495 DO 500 I = 1, NCOOR 4496 CHESS2(I,K) = CHESS2(I,K) + SYMCOR(I,J)*CHESS1(J,K) 4497 500 CONTINUE 4498C 4499C *** Print cartesian hessian *** 4500C 4501 CALL HEADER('Cartesian Hessian in GSPHES',-1) 4502 CALL PR2DER(CHESS2,NCOOR,NCOOR,LUPRI) 4503C 4504C *** Print to file if we are going to reuse the Hessian. *** 4505C 4506 IF (REUHES) THEN 4507 INQUIRE(FILE='DALTON.HES',EXIST=HESEXS) 4508C 4509C *** No hessian specified, we can safely write to file. *** 4510 IF (.NOT. HESEXS) THEN 4511C 4512C *** Open hessian file. *** 4513 LUHES = -1 4514 CALL GPOPEN(LUHES,'DALTON.HES','NEW',' ','FORMATTED', 4515 & IDUMMY,.FALSE.) 4516C 4517C *** Checking if this is going to be used with SPECTRO.*** 4518C 4519 IF (SPECTR) THEN 4520 NTIMES = NCOOR/3 4521 DO ICOOR2 = 1, NCOOR 4522 DO ITIMES = 1, NTIMES 4523 ISTART = 3*(ITIMES-1) + 1 4524 WRITE (LUHES,'(3F22.12)') 4525 & (CHESS2(ICOOR1,ICOOR2),ICOOR1=ISTART,ISTART+2) 4526 END DO 4527 END DO 4528 ELSE 4529C 4530C *** Printing necessary pre-hessian information. *** 4531 WRITE(LUHES,'(A)') 'CARTESIAN HESSIAN' 4532 WRITE(LUHES,*) NCOOR 4533 WRITE(LUHES,'(A)') ' ' 4534C 4535 DO 800 ICOOR2 = 1, NCOOR 4536 DO 900 ICOOR1 = 1, NCOOR 4537 WRITE (LUHES,'(F22.12)') CHESS2(ICOOR1,ICOOR2) 4538 900 CONTINUE 4539 WRITE (LUHES,'(A)') ' ' 4540 800 CONTINUE 4541 END IF 4542CRF Shouldn't this file be closed? 4543 CALL GPCLOSE(LUHES,'KEEP') 4544 ELSE IF (USE_PELIB()) THEN 4545 LUHES = -1 4546 CALL GPOPEN(LUHES,'DALTON.HES','UNKNOWN',' ','FORMATTED', 4547 & IDUMMY,.FALSE.) 4548 WRITE(LUHES,*) NCOOR 4549 WRITE(LUHES,'(A)') ' ' 4550 DO ICOOR2 = 1, NCOOR 4551 DO ICOOR1 = 1, NCOOR 4552 WRITE (LUHES,'(F22.12)') CHESS2(ICOOR1,ICOOR2) 4553 END DO 4554 WRITE (LUHES,'(A)') ' ' 4555 END DO 4556 CALL GPCLOSE(LUHES,'KEEP') 4557 ELSE 4558 WRITE (LUPRI,'(//A/A//)') 4559 & 'Hessian file "DALTON.HES" already exists.' // 4560 & ' This file will NOT be overwritten.', 4561 & 'Please restart the calculation without this file.' 4562 CALL QUIT('"DALTON.HES" already exists. See output.') 4563 END IF 4564 END IF 4565C 4566C *** Print *** 4567C 4568 IF (IPRINT .GT. 20) THEN 4569C 4570 KDIM = NCOOR**2 4571 CALL DZERO(CHESS1,KDIM) 4572C 4573 CALL HEADER('Symcor matrix',-1) 4574 DO 1100 I = 1, NCOOR 4575 WRITE (LUPRI,'(24F9.6)') (SYMCOR(I,J),J=1,NDCOOR) 4576 1100 CONTINUE 4577 WRITE (LUPRI,'(A)') ' ' 4578C 4579 CALL HEADER('Inverse of symcor matrix',-1) 4580 DO 1200 I = 1, NDCOOR 4581 WRITE (LUPRI,'(24F9.6)') (SMCINV(I,J),J=1,NCOOR) 4582 1200 CONTINUE 4583 WRITE (LUPRI,'(A)') ' ' 4584C 4585 DO 1300 K = 1, NCOOR 4586 DO 1300 J = 1, NDCOOR 4587 DO 1300 I = 1, NCOOR 4588 CHESS1(I,K) = CHESS1(I,K) + SYMCOR(I,J)*SMCINV(J,K) 4589 1300 CONTINUE 4590C 4591 CALL HEADER('Should be unit matrix',-1) 4592 DO 1400 J = 1, NCOOR 4593 WRITE (LUPRI,'(24F9.6)') (CHESS1(I,J),I=1,NCOOR) 4594 1400 CONTINUE 4595 END IF 4596 END IF 4597C 4598 1000 FORMAT (8X,20(I4,'/',I4,3X)) 4599 2000 FORMAT (I2,'/',I4,6F12.6) 4600 RETURN 4601 END 4602C 4603C 4604C /* Deck tsths1*/ 4605 SUBROUTINE TSTHS1(SYMCOR,HESMWT,EGNVCT,TM1TMP,TM2TMP,DKIN,WORK, 4606 & ICRIRP,LWORK) 4607************************************************************ 4608*** Tests the molecular hessian by makeing the cartesian *** 4609*** hessian, diagonalizing the mass-weighted hessian and *** 4610*** prints the eigenvalues, and harmonic frequencies *** 4611************************************************************ 4612#include "implicit.h" 4613#include "priunit.h" 4614#include "mxcent.h" 4615#include "codata.h" 4616 PARAMETER (DMTHR = 1.0D-9, D1 = 1.0D0) 4617#include "trkoor.h" 4618#include "nuclei.h" 4619#include "cbinum.h" 4620 DIMENSION SYMCOR(NCOOR,NCOOR), EGNVCT(NCOOR,NCOOR), 4621 & HESMWT(NCOOR*(NCOOR+1)/2), DKIN(NCOOR,NCOOR), 4622 & TM1TMP(NCOOR,NCOOR),TM2TMP(NCOOR,NCOOR), 4623 & WORK(LWORK) 4624 4625 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 4626C 4627 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4628 4629 KDIM = NCOOR**2 4630 CALL DZERO(TM1TMP,KDIM) 4631 DO 100 IC3 = 1, NCOOR 4632 DO 100 IC2 = 1, NCOOR 4633 DO 100 IC1 = 1, NCOOR 4634 TM1TMP(IC1,IC3) = TM1TMP(IC1,IC3) 4635 & + HESMOL(IC1,IC2)*SYMCOR(IC3,IC2) 4636 100 CONTINUE 4637C 4638 CALL DZERO(TM2TMP,KDIM) 4639 DO 200 IC3 = 1, NCOOR 4640 DO 200 IC2 = 1, NCOOR 4641 DO 200 IC1 = 1, NCOOR 4642 TM2TMP(IC1,IC3) = TM2TMP(IC1,IC3) 4643 & + SYMCOR(IC1,IC2)*TM1TMP(IC2,IC3) 4644 200 CONTINUE 4645C 4646 CALL HEADER('Cartesian hessian',-1) 4647 DO 300 IC1 = 1, NCOOR 4648 WRITE (LUPRI,'(12F8.5)') (HESMOL(IC1,IC2),IC2=1,NCOOR) 4649 300 CONTINUE 4650C 4651 CALL DZERO(TM1TMP,KDIM) 4652 DO 400 IC3 = 1, NCOOR 4653 DO 400 IC2 = 1, NCOOR 4654 DO 400 IC1 = 1, NCOOR 4655 TM1TMP(IC1,IC3) = TM1TMP(IC1,IC3) 4656 & + TM2TMP(IC1,IC2)*DKIN(IC2,IC3) 4657 400 CONTINUE 4658C 4659 CALL DZERO(TM2TMP,KDIM) 4660 DO 500 IC3 = 1, NCOOR 4661 DO 500 IC2 = 1, NCOOR 4662 DO 500 IC1 = 1, NCOOR 4663 TM2TMP(IC1,IC3) = TM2TMP(IC1,IC3) 4664 & + DKIN(IC1,IC2)*TM1TMP(IC2,IC3) 4665 500 CONTINUE 4666C 4667 IC12 = 0 4668 DO 600 IC2 = 1, NCOOR 4669 DO 600 IC1 = 1, IC2 4670 IC12 = IC12 + 1 4671 HESMWT(IC12) = TM2TMP(IC1,IC2) 4672 600 CONTINUE 4673C 4674 CALL HEADER('Mass-weighted hessian',-1) 4675 DO 700 IC1 = 1, NCOOR 4676 WRITE (LUPRI,'(12F8.5)') (TM2TMP(IC1,IC2),IC2=1,IC1) 4677 700 CONTINUE 4678C 4679 KWRK = 1 4680 KIWRK = KWRK + NCOOR 4681 CALL DUNIT(EGNVCT,NCOOR) 4682 CALL JACO(HESMWT,EGNVCT,NCOOR,NCOOR,NCOOR,WORK(KWRK),WORK(KIWRK)) 4683C 4684 CALL HEADER('Diagonalized hessian',-1) 4685 DO 800 IC1 = 1, NCOOR 4686 ISTART = (IC1*(IC1-1))/2 + 1 4687 IEND = (IC1*(IC1+1))/2 4688 WRITE (LUPRI,'(12F8.5)') (HESMWT(IC12),IC22=ISTART,IEND) 4689 800 CONTINUE 4690C 4691 RETURN 4692 END 4693C 4694C 4695C /*Deck sdertt*/ 4696 SUBROUTINE SDERTT(TSTSDR,TSTGDR,SYMCOR,TMPGRD,TMPHES, 4697 & WORK,LWORK,WRKDLM,IPRINT) 4698C ******************************************************************* 4699C *** This routine tests the numerical derivatives with available *** 4700C *** analytical derivatives. *** 4701C *** NOTE: TMPGRD has dimension MXCOOR due to old code. *** 4702C ******************************************************************* 4703#include "implicit.h" 4704#include "priunit.h" 4705#include "mxcent.h" 4706#include "maxorb.h" 4707#include "maxaqn.h" 4708 PARAMETER (D0 = 0.0D0) 4709#include "numder.h" 4710#include "trkoor.h" 4711#include "symmet.h" 4712#include "abainf.h" 4713#include "exeinf.h" 4714#include "gnrinf.h" 4715#include "past.h" 4716#include "inftap.h" 4717 DIMENSION TSTSDR(NCOOR,NCOOR), TSTGDR(NCOOR ), 4718 & TMPHES(NCOOR,NCOOR), TMPGRD(MXCOOR), 4719 & SYMCOR(NCOOR,NCOOR), WORK (LWORK ) 4720 4721 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 4722C 4723 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4724C 4725 DO 300 IC2 = 1, NCOOR 4726 DO 300 IC1 = 1, NCOOR 4727 TSTGDR(IC1) = TSTGDR(IC1) + SYMCOR(IC1,IC2)*GRDMOL(IC2) 4728 300 CONTINUE 4729C 4730 CALL DGEMM('N','N',NCOOR,NCOOR,NCOOR,1.D0, 4731 & SYMCOR,NCOOR, 4732 & HESMOL,NCOOR,0.D0, 4733 & TMPHES,NCOOR) 4734C 4735 CALL DGEMM('N','T',NCOOR,NCOOR,NCOOR,1.D0, 4736 & TMPHES,NCOOR, 4737 & SYMCOR,NCOOR,0.D0, 4738 & TSTSDR,NCOOR) 4739C 4740 GRDMOL(:) = 0.0D0 4741 HESMOL(:,:) = 0.0D0 4742 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4743C 4744 MOLGRD = .TRUE. 4745 MOLHES = .TRUE. 4746 PASEXC = .FALSE. 4747 RNABAC = .TRUE. 4748 WRINDX = .TRUE. 4749 FTRONV = .TRUE. 4750 DOWALK = .FALSE. 4751 LUSUPM = -1 4752 WORK(1) = WRKDLM 4753 CALL ABAINP('**PROPE',WORK(2),LWORK) 4754 CALL EXEABA(WORK(1),LWORK-1,WRKDLM) 4755 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4756C 4757C *** Transforming the analytical derivatives into *** 4758C *** cartesian basis. *** 4759C 4760 IF (MAXREP.GT.0) THEN 4761 KSCTR = 1 4762 KCSTR = KSCTR + NCOOR**2 4763 KLAST = KCSTR + NCOOR**2 4764 IF (KLAST.GT.LWORK) CALL QUIT('Memory exceeded inside SDERTT') 4765 CALL TRAGRD(GRDMOL,TMPGRD,WORK(KCSTR),WORK(KSCTR),NCRREP(0,1), 4766 & NCOOR) 4767 CALL TRAHES(HESMOL,NCOOR,TMPHES,WORK(KCSTR),WORK(KSCTR),NCOOR, 4768 & NCOOR,1) 4769 ELSE 4770 DO 400 IC2 = 1, NCOOR 4771 TMPGRD(IC2) = GRDMOL(IC2) 4772 DO 500 IC1 = 1, NCOOR 4773 TMPHES(IC1,IC2) = HESMOL(IC1,IC2) 4774 500 CONTINUE 4775 400 CONTINUE 4776 END IF 4777C 4778 RMAXGD = D0 4779 DO 600 J = 1, NCOOR 4780 RGRDJ = ABS(TMPGRD(J)-TSTGDR(J)) 4781 IF (RGRDJ .GT. RMAXGD) THEN 4782 RMAXGD = RGRDJ 4783 NMG = J 4784 END IF 4785 600 CONTINUE 4786 CALL HEADER('Comparison of numerical and analytical gradients',-1) 4787 WRITE (LUPRI,'(//A,1P,E13.5,A,I5/A,2E15.7)') 4788 & 'Largest difference ', RMAXGD,' for element:', NMG, 4789 & 'The values of these elements are: ',TMPGRD(NMG),TSTGDR(NMG) 4790 4791 RLRGST = D0 4792 DO 700 J = 1, NCOOR 4793 DO 700 I = 1, J 4794 RINTMD = (TMPHES(I,J)-TSTSDR(I,J))**2 4795 IF ( RINTMD .GT. RLRGST) THEN 4796 RLRGST = RINTMD 4797 NMI = I 4798 NMJ = J 4799 HVALC = TMPHES(I,J) 4800 HVALN = TSTSDR(I,J) 4801 END IF 4802 700 CONTINUE 4803C 4804 CALL HEADER('Comparison of numerical and analytical Hessians',-1) 4805 WRITE (LUPRI,'(//A,1P,E15.7,A,2I5)') 'Largest difference ', 4806 & SQRT(RLRGST), ' for elements:', NMI, NMJ 4807 WRITE (LUPRI,'(A,1P,2E15.7//)') 4808 & 'The values of these elements are: ',HVALC, HVALN 4809C 4810 RETURN 4811 END 4812C 4813C 4814C /* Deck drnrmc*/ 4815 SUBROUTINE DRNRMC(SYMCOR,ICRIRP,IPRINT) 4816 ! DRYRUN version of MKNRMC, 4817 ! make normal coordinates 4818#include "implicit.h" 4819#include "priunit.h" 4820#include "mxcent.h" 4821C 4822#include "trkoor.h" 4823#include "numder.h" 4824#include "fcsym.h" 4825 LOGICAL FOUND 4826 DIMENSION SYMCOR(NCOOR,NCOOR), ICRIRP(NCOOR,2) 4827 4828 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 4829C 4830 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 4831 4832 DO 100 IC1 = 1, NMREDU 4833 FOUND = .FALSE. 4834 IIREP = KDRYRN(IC1) 4835C 4836 DO 200 IC2 = 1, NDCOOR 4837 IF ((ICRIRP(IC2,1).EQ.IIREP).AND.(.NOT.FOUND)) THEN 4838 FOUND = .TRUE. 4839 DO 300 II = 1, 2 4840 DO 300 IC3 = IC2+1, NDCOOR 4841 ICRIRP(IC3-1,II) = ICRIRP(IC3,II) 4842 300 CONTINUE 4843 NDCOOR = NDCOOR - 1 4844C 4845 IF (IIREP.GT.N1DIME) THEN 4846 FOUND = .FALSE. 4847 DO 400 IC3 = IC2-1, NDCOOR 4848 IF ((ICRIRP(IC3,1).EQ.IIREP).AND. 4849 & (ICRIRP(IC3,2).EQ. 1).AND.(.NOT.FOUND)) THEN 4850 FOUND = .TRUE. 4851 DO 500 II = 1, 2 4852 DO 500 IC4 = IC3+1, NDCOOR 4853 ICRIRP(IC4-1,II) = ICRIRP(IC4,II) 4854 500 CONTINUE 4855 END IF 4856 400 CONTINUE 4857 NDCOOR = NDCOOR - 1 4858 END IF 4859 END IF 4860 200 CONTINUE 4861 100 CONTINUE 4862C 4863 IF (IPRINT.GT.20) THEN 4864 WRITE (LUPRI,'(5X,A)') 'Removed translational and rotational'// 4865 & 'redundencies.' 4866 WRITE (LUPRI,'(A)') ' ' 4867 WRITE (LUPRI,'(5X,A)') 'Symmetry of coordinates left:' 4868 WRITE (LUPRI,'(5X,24I5)') (ICRIRP(II,1),II=1,NDCOOR) 4869 WRITE (LUPRI,'(5X,24I5)') (ICRIRP(II,2),II=1,NDCOOR) 4870 END IF 4871 RETURN 4872 END 4873C 4874C 4875C /* Deck wricor*/ 4876 SUBROUTINE WRICOR(SYMCOR,RNNORM,FREQ,ICRIRP,LURSTR,IPRINT) 4877C ************************************************* 4878C *** This is a routine that writes out normal *** 4879C *** coordinates to file, in case of a restart.*** 4880C ************************************************* 4881#include "implicit.h" 4882#include "priunit.h" 4883#include "mxcent.h" 4884C 4885#include "trkoor.h" 4886#include "numder.h" 4887 DIMENSION SYMCOR(NCOOR,NCOOR), RNNORM(NCOOR), FREQ(NCOOR) 4888 DIMENSION ICRIRP(NCOOR,2) 4889C 4890 WRITE (LURSTR,'(I8)') NDCOOR 4891C 4892C *** Writing normal coordinates. *** 4893C 4894 DO 100 IC2 = 1, NDCOOR 4895 WRITE(LURSTR,'(2I5)') (ICRIRP(IC2,I),I=1,2) 4896 DO 200 IC1 = 1, NCOOR 4897 WRITE(LURSTR,'(F24.16)') SYMCOR(IC1,IC2) 4898 200 CONTINUE 4899 100 CONTINUE 4900C 4901C *** Norm of the non-normalized normal coordinates. *** 4902C 4903 WRITE(LURSTR,'(A)') 'Norm' 4904 DO 300 IC = 1, NDCOOR 4905 WRITE(LURSTR,'(F24.16)') RNNORM(IC) 4906 300 CONTINUE 4907C 4908C *** Frequencies. *** 4909C 4910 WRITE(LURSTR,'(A)') 'Freq' 4911 DO 400 IC = 1, NDCOOR 4912 WRITE(LURSTR,'(F24.16)') FREQ(IC) 4913 400 CONTINUE 4914 CALL FLSHFO(LURSTR) 4915C 4916 RETURN 4917 END 4918C 4919C 4920C /*Deck rerstr*/ 4921 SUBROUTINE RERSTR(FUNVAL,SYMCOR,RNNORM,FREQ,ICRIRP,NDIME,NINTIN, 4922 & KEND,IDIMAX,IDIMIN,LURSTR,IPRINT,RSTDON) 4923#include "implicit.h" 4924#include "priunit.h" 4925#include "mxcent.h" 4926C 4927#include "trkoor.h" 4928#include "numder.h" 4929 LOGICAL RSTDON 4930 DIMENSION SYMCOR(NCOOR,NCOOR), FUNVAL(NINTIN,NDIME), 4931 & RNNORM(NCOOR), FREQ(NCOOR) 4932 DIMENSION ICRIRP(NCOOR,2) 4933C 4934 CALL DZERO(FUNVAL,NINTIN*NDIME) 4935C 4936 READ(LURSTR,*) II 4937C 4938C *** The program ended the second time around. *** 4939C *** Need to read in additional information. *** 4940C 4941 IF ((II.EQ.1) .AND. (II.EQ.KEND)) THEN 4942 CALL RDHDRS(SYMCOR,RNNORM,FREQ,ICRIRP,NCOOR,NDCOOR,LURSTR) 4943 END IF 4944 4945 IF (((II.EQ.0) .AND. (II.EQ.KEND)).OR. 4946 & ((II.EQ.1) .AND. (II.EQ.KEND))) THEN 4947 RSTDON = .TRUE. 4948C 4949C *** Reading the function values *** 4950C 4951 100 CONTINUE 4952 READ(LURSTR,FMT=*,IOSTAT=IOS) IINTIN, IDIME, ENERGY 4953 IF (IOS.GE.0) THEN 4954 IDIMAX = MAX(IDIMAX,IDIME) 4955 IDIMIN = MIN(IDIMIN,IDIME) 4956 FUNVAL(IINTIN,IDIME) = ENERGY 4957 GOTO 100 4958 END IF 4959 END IF 4960C 4961 RETURN 4962 END 4963C 4964C 4965C /*Deck prprer*/ 4966 SUBROUTINE PRPRER(WORK,IDIMAX,IDIMIN,LURSTR,LWORK) 4967C ************************************************* 4968C *** Restart routine for property derivatives. *** 4969C ************************************************* 4970#include "implicit.h" 4971#include "priunit.h" 4972#include "mxcent.h" 4973 CHARACTER*9 PRPTXT 4974 DIMENSION WORK(LWORK) 4975#include "numder.h" 4976#include "trkoor.h" 4977#include "dummy.h" 4978C 4979 KNMPRP = 0 4980 INMTCL = 0 4981 100 CONTINUE 4982 READ (LUNDPR,FMT='(A9)',IOSTAT=IOS) PRPTXT 4983 IF (IOS.GE.0) THEN 4984 READ (LUNDPR,'(4I7)') NDIM1, NDIM2, NDIM3, KNMCLC 4985C 4986C *** Figures out which property to read in, and reads it. *** 4987C 4988 KGRBG = 1 4989 CALL CHPRRD(WORK(KGRBG),WORK(KGRBG),WORK(KGRBG),WORK(KGRBG), 4990 & WORK(KGRBG),NDIM1,NDIM2,NDIM3,PRPTXT,IDUMMY) 4991C 4992C *** Another property has been calculated. *** 4993C 4994 INMTCL = INMTCL + 1 4995C 4996C *** Calculating number of properties per geometry. *** 4997C 4998 IF (KNMCLC .EQ. 1) THEN 4999 KNMPRP = KNMPRP + 1 5000 END IF 5001C 5002 GOTO 100 5003 END IF 5004C 5005 IF (KNMCLC.EQ.1) THEN 5006C 5007C *** Only some properties for first geometry has been *** 5008C *** calculated. Nothing to save, continue from beginning. *** 5009C 5010 REWIND(LUNDPR) 5011 IDIMAX = IDIMAX - 1 5012 ELSE 5013C 5014C *** If not all properties were written for the *** 5015C *** last geometry. We need to make sure that we*** 5016C *** are at the end of a geometry. *** 5017C 5018 IF (KNMCLC*KNMPRP.GT.INMTCL) THEN 5019C 5020C *** We can only use the restart for the previous *** 5021C *** geometry. *** 5022C 5023 IF (KNMCLC.EQ.IDIMAX) THEN 5024C *** Original geometry. *** 5025 IDIMIN = 2 5026 ELSE 5027 IDIMAX = IDIMAX -1 5028 END IF 5029 KNMCLC = KNMCLC - 1 5030C 5031C *** Positioning the property file. *** 5032C 5033 REWIND(LUNDPR) 5034 DO INMCLC = 1, KNMCLC 5035 DO INMPRP = 1, KNMPRP 5036 READ (LUNDPR,FMT='(A9)',IOSTAT=IOS) PRPTXT 5037 READ (LUNDPR,'(4I7)') NDIM1, NDIM2, NDIM3, KGRB 5038C 5039C *** Figures out which property to read in, and *** 5040C *** reads it. *** 5041C 5042 KGRB = 1 5043 CALL CHPRRD(WORK(KGRB),WORK(KGRB),WORK(KGRB),WORK(KGRB), 5044 & WORK(KGRB),NDIM1,NDIM2,NDIM3,PRPTXT,IDUMMY) 5045 END DO 5046 END DO 5047C 5048C *** Positioning the RSTRT.FC file. *** 5049C 5050 REWIND(LURSTR) 5051 READ(LURSTR,*) II 5052 IF (II.EQ.1) THEN 5053 KGRB = 1 5054 CALL RDHDRS(WORK(KGRB),WORK(KGRB),WORK(KGRB), 5055 & WORK(KGRB),NCOOR,IDUMMY,LURSTR) 5056 END IF 5057C 5058 DO ID = IDIMIN, IDIMAX 5059 READ(LURSTR,FMT=*,IOSTAT=IOS) KGRBG1, KGRBG2, GARBAG 5060 END DO 5061 END IF 5062 END IF 5063C 5064C *** Finally setting number of calculations done. *** 5065C 5066 NMDPRP = KNMCLC*KNMPRP 5067C 5068 RETURN 5069 END 5070C 5071C 5072C /* Deck rdhdrs */ 5073 SUBROUTINE RDHDRS(SYMCOR,RNNORM,FREQ,ICRIRP,NCOOR,NDCOOR,LURSTR) 5074C ********************************************************* 5075C *** Subroutine that reads in header of force constant *** 5076C *** restart routine. *** 5077C ********************************************************* 5078#include "implicit.h" 5079#include "priunit.h" 5080C 5081 DIMENSION SYMCOR(NCOOR,NCOOR), RNNORM(NCOOR), FREQ(NCOOR) 5082 DIMENSION ICRIRP(NCOOR,2) 5083 5084C 5085C *** Number of normal coordinates *** 5086C 5087 READ(LURSTR,FMT='(I8)') NDCOOR 5088C 5089C *** The normal coordinates. *** 5090C 5091 DO IC2 = 1, NDCOOR 5092 READ(LURSTR,'(2I5)') (ICRIRP(IC2,I),I=1,2) 5093 DO IC1 = 1, NCOOR 5094 READ(LURSTR,'(F24.16)') SYMCOR(IC1,IC2) 5095 END DO 5096 END DO 5097C 5098C *** Norm of the non-normalized normal coordinates. *** 5099C 5100 READ(LURSTR,FMT='(A)') 5101 DO IC = 1, NDCOOR 5102 READ(LURSTR,'(F24.16)') RNNORM(IC) 5103 END DO 5104C 5105C *** Frequencies. *** 5106C 5107 READ(LURSTR,FMT='(A)') 5108 DO IC = 1, NDCOOR 5109 READ(LURSTR,'(F24.16)') FREQ(IC) 5110 END DO 5111C 5112 RETURN 5113 END 5114C 5115C /*Deck nrmiso*/ 5116 SUBROUTINE NRMISO(TDER,SYMCOR,DKIN,TRNCCR,TRAMSS,TMPGRD,TMPHES, 5117 & TMPMSS,TMPTD1,TMPTD2,CSTART,WORK,NDIMT,LWORK, 5118 & IPRINT) 5119C *************************************************************** 5120C *** This routine takes the force constants (with respect to *** 5121C *** the most normal masses) and finds the force constants *** 5122C *** with respect to other isotopes). *** 5123C *************************************************************** 5124#include "implicit.h" 5125#include "priunit.h" 5126#include "mxcent.h" 5127C 5128#include "trkoor.h" 5129#include "numder.h" 5130 LOGICAL HESEXS 5131 INTEGER BEGIN 5132 DIMENSION TDER(NDIMT), SYMCOR(NCOOR,NCOOR), TRNCCR(NCOOR,NCOOR), 5133 & TRAMSS(NCOOR), DKIN(NCOOR), TMPGRD(NCOOR), 5134 & TMPHES(NCOOR,NCOOR), TMPMSS(NCOOR), CSTART(NCOOR), 5135 & TMPTD1(NCOOR,NCOOR,NCOOR), TMPTD2(NCOOR,NCOOR,NCOOR) 5136 5137 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 5138C 5139 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 5140 KDIMH = NCOOR**2 5141 KDIMT = NCOOR**3 5142C 5143C *** Making the third derivative ready for transformation. *** 5144C 5145 NCOUNT = 0 5146 DO 100 IC3 = 1, NCOOR 5147 DO 100 IC2 = 1, IC3 5148 DO 100 IC1 = 1, IC2 5149 NCOUNT = NCOUNT + 1 5150 TMPTD1(IC1,IC2,IC3) = TDER(NCOUNT) 5151 TMPTD1(IC1,IC3,IC2) = TDER(NCOUNT) 5152 TMPTD1(IC2,IC1,IC3) = TDER(NCOUNT) 5153 TMPTD1(IC2,IC3,IC1) = TDER(NCOUNT) 5154 TMPTD1(IC3,IC2,IC1) = TDER(NCOUNT) 5155 TMPTD1(IC3,IC1,IC2) = TDER(NCOUNT) 5156 100 CONTINUE 5157C 5158C *** Averaged masses needed to be used to transform *** 5159C *** to mass-weighted coordinates. *** 5160C 5161 CALL DZERO(TMPMSS,NDCOOR) 5162 DO 200 IC2 = 1, NDCOOR 5163 DO 200 IC1 = 1, NCOOR 5164 TMPMSS(IC2) = TMPMSS(IC2) + (SYMCOR(IC1,IC2)/DKIN(IC1))**2 5165 200 CONTINUE 5166C 5167C *** Mass weigting (with the average masses) the force constants *** 5168C *** to transform to mass-weighted coordinates. *** 5169C 5170C *** Gradient. *** 5171 DO 300 IC1 = 1, NDCOOR 5172 GRDMOL(IC1) = GRDMOL(IC1)/SQRT(TMPMSS(IC1)) 5173 300 CONTINUE 5174C *** Hessian. *** 5175 DO 400 IC1 = 1, NDCOOR 5176 HESMOL(IC1,IC1) = HESMOL(IC1,IC1)/TMPMSS(IC1) 5177 400 CONTINUE 5178C *** Third derivative *** 5179 DO 500 IC3 = 1, NDCOOR 5180 DO 500 IC2 = 1, NDCOOR 5181 DO 500 IC1 = 1, NDCOOR 5182 TMPTD1(IC1,IC2,IC3) = 5183 & TMPTD1(IC1,IC2,IC3)/(SQRT(TMPMSS(IC1)*TMPMSS(IC2)*TMPMSS(IC3))) 5184 500 CONTINUE 5185C 5186C *** Transforming the force constants back to mass weighted *** 5187C *** cartesian coordinates. *** 5188C 5189C *** Gradient *** 5190 CALL DZERO(TMPGRD,NCOOR) 5191 DO 600 IC2 = 1, NDCOOR 5192 DO 600 IC1 = 1, NCOOR 5193 TMPGRD(IC1) = TMPGRD(IC1) + TRNCCR(IC1,IC2)*GRDMOL(IC2) 5194 600 CONTINUE 5195C *** Hessian *** 5196 CALL DZERO(TMPHES,KDIMH) 5197 DO 700 IC3 = 1, NCOOR 5198 DO 700 IC2 = 1, NDCOOR 5199 DO 700 IC1 = 1, NDCOOR 5200 TMPHES(IC1,IC3) = TMPHES(IC1,IC3) 5201 & + HESMOL(IC1,IC2)*TRNCCR(IC3,IC2) 5202 700 CONTINUE 5203 HESMOL(:,:) = 0.0D0 5204 DO 800 IC3 = 1, NCOOR 5205 DO 800 IC2 = 1, NDCOOR 5206 DO 800 IC1 = 1, NCOOR 5207 HESMOL(IC1,IC3) = HESMOL(IC1,IC3) 5208 & + TRNCCR(IC1,IC2)*TMPHES(IC2,IC3) 5209 800 CONTINUE 5210C *** Third derivative *** 5211 CALL DZERO(TMPTD2,KDIMT) 5212 DO 900 IC4 = 1, NDCOOR 5213 DO 900 IC3 = 1, NDCOOR 5214 DO 900 IC2 = 1, NDCOOR 5215 DO 900 IC1 = 1, NCOOR 5216 TMPTD2(IC1,IC3,IC4) = TMPTD2(IC1,IC3,IC4) 5217 & + TRNCCR(IC1,IC2)*TMPTD1(IC2,IC3,IC4) 5218 900 CONTINUE 5219 CALL DZERO(TMPTD1,KDIMT) 5220 DO 1000 IC4 = 1, NDCOOR 5221 DO 1000 IC3 = 1, NDCOOR 5222 DO 1000 IC2 = 1, NCOOR 5223 DO 1000 IC1 = 1, NCOOR 5224 TMPTD1(IC1,IC2,IC4) = TMPTD1(IC1,IC2,IC4) 5225 & + TRNCCR(IC2,IC3)*TMPTD2(IC1,IC3,IC4) 5226 1000 CONTINUE 5227 CALL DZERO(TMPTD2,KDIMT) 5228 DO 1100 IC4 = 1, NDCOOR 5229 DO 1100 IC3 = 1, NCOOR 5230 DO 1100 IC2 = 1, NCOOR 5231 DO 1100 IC1 = 1, NCOOR 5232 TMPTD2(IC1,IC2,IC3) = TMPTD2(IC1,IC2,IC3) 5233 & + TRNCCR(IC3,IC4)*TMPTD1(IC1,IC2,IC4) 5234 1100 CONTINUE 5235C 5236C *** Mass transformation. *** 5237C 5238C *** Gradient *** 5239 GRDMOL(:) = 0.0D0 5240 DO 1200 IC1 = 1, NCOOR 5241 GRDMOL(IC1) = GRDMOL(IC1) + TRAMSS(IC1)*TMPGRD(IC1) 5242 1200 CONTINUE 5243C *** Hessian *** 5244 CALL DZERO(TMPHES,KDIMH) 5245 DO 1300 IC2 = 1, NCOOR 5246 DO 1300 IC1 = 1, NCOOR 5247 TMPHES(IC1,IC2) = TMPHES(IC1,IC2)+ HESMOL(IC1,IC2)*TRAMSS(IC2) 5248 1300 CONTINUE 5249 HESMOL(:,:) = 0.0D0 5250 DO 1400 IC2 = 1, NCOOR 5251 DO 1400 IC1 = 1, NCOOR 5252 HESMOL(IC1,IC2) = HESMOL(IC1,IC2)+ TRAMSS(IC1)*TMPHES(IC1,IC2) 5253 1400 CONTINUE 5254C *** Third derivative. *** 5255 CALL DZERO(TMPTD1,KDIMT) 5256 DO 1500 IC3 = 1, NCOOR 5257 DO 1500 IC2 = 1, NCOOR 5258 DO 1500 IC1 = 1, NCOOR 5259 TMPTD1(IC1,IC2,IC3) = TMPTD1(IC1,IC2,IC3) 5260 & + TRAMSS(IC1)*TMPTD2(IC1,IC2,IC3) 5261 1500 CONTINUE 5262 CALL DZERO(TMPTD2,KDIMT) 5263 DO 1600 IC3 = 1, NCOOR 5264 DO 1600 IC2 = 1, NCOOR 5265 DO 1600 IC1 = 1, NCOOR 5266 TMPTD2(IC1,IC2,IC3) = TMPTD2(IC1,IC2,IC3) 5267 & + TRAMSS(IC2)*TMPTD1(IC1,IC2,IC3) 5268 1600 CONTINUE 5269 CALL DZERO(TMPTD1,KDIMT) 5270 DO 1700 IC3 = 1, NCOOR 5271 DO 1700 IC2 = 1, NCOOR 5272 DO 1700 IC1 = 1, NCOOR 5273 TMPTD1(IC1,IC2,IC3) = TMPTD1(IC1,IC2,IC3) 5274 & + TRAMSS(IC3)*TMPTD2(IC1,IC2,IC3) 5275 1700 CONTINUE 5276C 5277C *** Temporary code, please remove *** 5278C 5279 INQUIRE(FILE='DALTON.HES',EXIST=HESEXS) 5280C 5281C *** No hessian specified, we can safely write to file. *** 5282 IF (.NOT. HESEXS) THEN 5283C 5284C *** Open hessian file. *** 5285 LUHES = -1 5286 CALL GPOPEN(LUHES,'DALTON.HES','NEW',' ','FORMATTED',IDUMMY, 5287 & .FALSE.) 5288C 5289C *** Printing necessary pre-hessian information. *** 5290 WRITE(LUHES,'(A)') 'CARTESIAN HESSIAN' 5291 WRITE(LUHES,*) NCOOR 5292 WRITE(LUHES,'(A)') ' ' 5293C 5294 DO 1800 ICOOR2 = 1, NCOOR 5295 DO 1900 ICOOR1 = 1, NCOOR 5296 WRITE (LUHES,'(F22.12)') HESMOL(ICOOR1,ICOOR2) 5297 1900 CONTINUE 5298 WRITE (LUHES,'(A)') ' ' 5299 1800 CONTINUE 5300 ELSE 5301 WRITE (LUPRI,'(//A/A//)') 5302 & 'Hessian file "DALTON.HES" already exists.' // 5303 & ' This file will NOT be overwritten.', 5304 & 'Please restart the calculation without this file.' 5305 CALL QUIT('"DALTON.HES" already exists. See output.') 5306 END IF 5307C 5308C *** Print section. *** 5309C 5310C *** Gradient. *** 5311 WRITE (LUPRI,'(A)') 'Gradient in symmetry coordinates.' 5312 DO IC =1, NCOOR 5313 WRITE (LUPRI,'(F12.7)') GRDMOL(IC) 5314 END DO 5315C 5316C *** Hessian. *** 5317C 5318 BEGIN = 1 5319 KCOL = 6 5320 LAST = MIN(NCOOR,KCOL) 5321 KCOOR = NCOOR 5322 NCOL = NCOOR/KCOL 5323 IF (MOD(NCOOR,KCOL).NE.0) NCOL = NCOL + 1 5324C 5325 DO 101 ICOL = 1, NCOL 5326 WRITE (LUPRI,1001) (I,I = BEGIN,LAST) 5327C 5328 DO 201 ICOOR = BEGIN, NCOOR 5329 WRITE (LUPRI,2001) ICOOR, 5330 & (HESMOL(ICOOR,I),I=BEGIN,MIN(LAST,ICOOR)) 5331 201 CONTINUE 5332 WRITE (LUPRI,'(A)') ' ' 5333 BEGIN = BEGIN + KCOL 5334 LAST = MIN(NCOOR,KCOL+LAST) 5335 101 CONTINUE 5336 1001 FORMAT (8X,6(I7,5X),(I7,5X)) 5337 2001 FORMAT (I5,2X,6F12.6) 5338C 5339C *** Qubic force field. *** 5340C 5341 CALL HEADER('Third derivative in symmetry coordinates.',-1) 5342C 5343 IF (MOD(NCOOR,6).EQ.0) THEN 5344 NLCMAX = NCOOR/6 5345 ELSE 5346 NLCMAX = INT(NCOOR/6)+1 5347 END IF 5348C 5349 DO 202 ICOL2 = 1, NCOOR 5350 WRITE (LUPRI,'(A,I3)') ' Coloumn number', ICOL2 5351 WRITE (LUPRI,'(A)') ' -----------------' 5352 INLC = 0 5353 DO 402 INLCMX = 1, NLCMAX 5354 INLC2 = 6*(INLCMX-1) + 1 5355 INLC = MIN(INLC+6,NCOOR) 5356 DO 302 ICOL1 = 1, NCOOR 5357 WRITE (LUPRI,'(3X,6F10.6)') 5358 & (TMPTD1(I,ICOL1,ICOL2),I=INLC2,INLC) 5359 302 CONTINUE 5360 WRITE (LUPRI,'(A)') ' ' 5361 402 CONTINUE 5362 202 CONTINUE 5363C 5364 IF (IPRINT .GT. 22) THEN 5365 WRITE (LUPRI,'(A)') 'Inverse of averaged mass' 5366 WRITE (LUPRI,'(12F10.7)') (TMPMSS(I),I=1,NDCOOR) 5367 END IF 5368C 5369 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 5370 RETURN 5371 END 5372C 5373C 5374C /*Deck dalchg*/ 5375 SUBROUTINE DALCHG(INDSTP,ICRIRP,IRSRDR,IPRINT,NCOOR,NTORDR,FIRST) 5376C *********************************************************** 5377C *** Routine that reduces the symmetry in the DALTON.INP *** 5378C *** file, according to the distortions. *** 5379C *********************************************************** 5380#include "implicit.h" 5381#include "priunit.h" 5382#include "mxcent.h" 5383C 5384#include "molinp.h" 5385#include "fcsym.h" 5386#include "ccorb.h" 5387 LOGICAL FIRST 5388 CHARACTER*(len_MLINE) WORD(KMLINE) 5389 DIMENSION ICRIRP(NCOOR,2), INDSTP(NTORDR) 5390C 5391 CALL GPOPEN(LUCMD,'DALTON.INP','OLD',' ','FORMATTED',IDUMMY, 5392 & .FALSE.) 5393C 5394 ILINE = 0 5395 REWIND (LUCMD,IOSTAT=IOS) 5396 100 READ (LUCMD,'(A)',ERR=2000) WORD(ILINE+1) 5397 CALL UPCASE(WORD(ILINE+1)) 5398 ILINE = ILINE + 1 5399 IF (INDEX(WORD(ILINE),'*END OF').GT.0) GOTO 200 5400 GOTO 100 5401C 5402 200 CONTINUE 5403 DO 300 I = 1, ILINE 5404 IF (WORD(I)(1:7) .EQ. '.NSYM ') THEN 5405 IF (FIRST) THEN 5406 READ (WORD(I+1),*) NSMBKP 5407 ELSE 5408 NSYM = NSMBKP 5409 DO 400 J = 1, IRSRDR+1 5410 IF ((ICRIRP(INDSTP(J),1).NE.1).AND.(NSYM.GT.1)) THEN 5411 NSYM = NSYM/2 5412 END IF 5413 400 CONTINUE 5414 WRITE (WORD(I+1),'(I4)') NSYM 5415 END IF 5416 END IF 5417 300 CONTINUE 5418C 5419 REWIND (LUCMD,IOSTAT=IOS) 5420 DO 500 I = 1, ILINE 5421 WRITE (LUCMD,'(A)') WORD(I) 5422 500 CONTINUE 5423 CALL GPCLOSE(LUCMD,'KEEP') 5424C 5425 RETURN 5426 2000 CONTINUE 5427 CALL QUIT('There are problems in correcting the .NSYM parameter') 5428 END 5429C 5430C 5431C /* Deck rdhess */ 5432 SUBROUTINE RDHESS(SYMCOR,CSTART,GRIREP,CHRCTR,HESSIN,WORK,ICRIRP, 5433 & LWORK,IPRINT,SYMDET) 5434C ********************************************************** 5435C **** Subroutine that reads in a precalculated hessian **** 5436C **** uses this for further work in normal coordinates.**** 5437C ********************************************************** 5438#include "implicit.h" 5439#include "priunit.h" 5440#include "mxcent.h" 5441C 5442#include "fcsym.h" 5443#include "trkoor.h" 5444 LOGICAL SYMDET, SYMADA 5445 DIMENSION SYMCOR(NCOOR ,NCOOR ), CSTART(NCOOR ), 5446 & GRIREP(NGORDR,NGVERT), CHRCTR(NGORDR,NCVERT), 5447 & HESSIN(NCOOR ,NCOOR), WORK (LWORK) 5448 DIMENSION ICRIRP(NCOOR,2) 5449 5450 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 5451 5452C 5453C *** Initializing. *** 5454 SYMADA = .FALSE. 5455C 5456C *** Making symmetry adapted coordinates. *** 5457C 5458 CALL GRPCHR(CSTART,SYMCOR,GRIREP,CHRCTR,WORK,ICRIRP,LWORK,IPRINT) 5459C 5460C *** Declaring that the symmetry of the system is determined. *** 5461 SYMDET = .FALSE. 5462C 5463C *** Reading in the hessian *** 5464C 5465 CALL RDFHES(WORK,LWORK,IPRINT,SYMADA) 5466C 5467 IF (.NOT. SYMADA) THEN 5468C 5469C *** The hessian is cartesian coordinates. Transform it to *** 5470C *** Symmetry adapted coordinates. *** 5471C 5472 KTMPHS = 1 5473 KLAST = KTMPHS + NCOOR**2 5474 LWRK = LWORK - KLAST 5475 CALL TRGHES(HESSIN,SYMCOR,WORK(KTMPHS),WORK(KLAST),NCOOR,LWRK, 5476 & IPRINT,'symmetry ') 5477C 5478 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 5479 5480 DO 100 ICOOR2 = 1, NCOOR 5481 DO 100 ICOOR1 = 1, NCOOR 5482 HESMOL(ICOOR1,ICOOR2) = HESSIN(ICOOR1,ICOOR2) 5483 100 CONTINUE 5484 5485 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 5486 5487 END IF 5488C 5489C *** Print! *** 5490C 5491 IF (IPRINT .GT. 4) THEN 5492 CALL HEADER ('Final hessian from RDHESS',0) 5493C 5494 N = 0 5495 IF (MOD(NCOOR,6).NE.0) N = 1 5496 NCOL = NCOOR/6 + N 5497 NSTART = 1 5498 NEND = MIN(NCOOR,6) 5499 DO I = 1, NCOL 5500 DO ICOOR1 = 1, NCOOR 5501 WRITE (LUPRI,'(6F14.6)') 5502 & (HESMOL(ICOOR1,ICOOR2), ICOOR2= NSTART, NEND) 5503 END DO 5504 NSTART = NEND + 1 5505 NEND = MIN(NCOOR,NEND+6) 5506 WRITE (LUPRI,'(A)') ' ' 5507 WRITE (LUPRI,'(A)') ' ' 5508 END DO 5509 END IF 5510C 5511 RETURN 5512 END 5513C 5514C /* Deck rdfhes */ 5515 SUBROUTINE RDFHES(WORK,LWORK,IPRINT,SYMADA) 5516#include "implicit.h" 5517#include "priunit.h" 5518#include "mxcent.h" 5519CRF added 5520#include "numder.h" 5521C 5522#include "nuclei.h" 5523#include "trkoor.h" 5524 LOGICAL SYMADA, HESEXS 5525 CHARACTER*5 HSMINF 5526 DIMENSION WORK(LWORK) 5527 5528 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 5529C 5530 IF (C4FORC) THEN ! We should read a CFOUR style Hessian file 5531 CALL RDC4HS(WORK,LWORK,IPRINT) 5532 GOTO 300 5533 END IF 5534 5535 INQUIRE(FILE='DALTON.HES',EXIST=HESEXS) 5536C 5537C *** No hessian specified. *** 5538 IF (.NOT. HESEXS) CALL QUIT('Unable to open the file DALTON.HES.') 5539C 5540C *** Open hessian file. *** 5541 LUHES = -1 5542 CALL GPOPEN(LUHES,'DALTON.HES','OLD',' ','FORMATTED',IDUMMY, 5543 & .FALSE.) 5544C 5545C *** Specified hessian in symmetry coordinates? *** 5546 READ(LUHES,'(A5)') HSMINF 5547 IF (HSMINF .EQ. 'SYMME') SYMADA = .TRUE. 5548C 5549C *** Check if the speciefied dimensions match those from MOLECULE.INP. *** 5550 READ(LUHES,*) IDIM 5551 IF (IDIM .NE. 3*NUCDEP) CALL QUIT('Dimensions for specified ' // 5552 & 'Hessian does not match those found from the molecule-file.') 5553 READ(LUHES,*) 5554 5555C 5556C *** Read the hessian from file. *** 5557C 5558 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 5559 DO 100 ICOOR2 = 1, NCOOR 5560C 5561 DO 200 ICOOR1 = 1, NCOOR 5562 READ(LUHES,*) HESMOL(ICOOR1,ICOOR2) 5563 200 CONTINUE 5564C 5565 READ(LUHES,*) 5566 100 CONTINUE 5567C 5568 CALL GPCLOSE(LUHES,'KEEP') 5569C 5570 300 CONTINUE 5571 CALL HEADER ('Molecular Hessian read from file.', 0) 5572 WRITE (LUPRI,'(A)') ' ' 5573 CALL HEADER ('Molecular Hessian', -1) 5574 call flshfo(lupri) 5575C 5576 N = 0 5577 IF (MOD(NCOOR,6).NE.0) N = 1 5578 NCOL = NCOOR/6 + N 5579 NSTART = 1 5580 NEND = MIN(NCOOR,6) 5581 DO I = 1, NCOL 5582 DO ICOOR1 = 1, NCOOR 5583 WRITE (LUPRI,'(6F14.6)') 5584 & (HESMOL(ICOOR1,ICOOR2), ICOOR2= NSTART, NEND) 5585 END DO 5586 NSTART = NEND + 1 5587 NEND = MIN(NCOOR,NEND+6) 5588 WRITE (LUPRI,'(A)') ' ' 5589 WRITE (LUPRI,'(A)') ' ' 5590 END DO 5591C 5592 CALL FLSHFO(LUPRI) 5593C 5594 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 5595 5596 RETURN 5597 END 5598C 5599C /* Deck trahes */ 5600 SUBROUTINE TRGHES(HESSIN,SYMCOR,TMPHES,WORK,NCOOR,LWORK,IPRINT, 5601 & TYPE) 5602C ********************************************************** 5603C *** Transforming hessian in cartesian coordinates, to **** 5604C *** symmetry coordinate basis in SYMCOR. **** 5605C ********************************************************** 5606#include "implicit.h" 5607#include "priunit.h" 5608#include "mxcent.h" 5609C 5610 CHARACTER*9 TYPE 5611 DIMENSION HESSIN(NCOOR,NCOOR), SYMCOR(NCOOR,NCOOR), 5612 & TMPHES(NCOOR,NCOOR), WORK(LWORK) 5613 5614 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 5615C 5616C *** Cartesian to symmetric transformation. *** 5617 IF (TYPE .EQ. 'symmetry ') THEN 5618 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 5619C 5620 KDIM = NCOOR**2 5621C 5622 CALL DZERO(TMPHES,KDIM) 5623 DO 100 ICOOR3 = 1, NCOOR 5624 DO 100 ICOOR2 = 1, NCOOR 5625 DO 100 ICOOR1 = 1, NCOOR 5626 TMPHES(ICOOR1,ICOOR3) = TMPHES(ICOOR1,ICOOR3) 5627 & + SYMCOR(ICOOR2,ICOOR1)*HESMOL(ICOOR2,ICOOR3) 5628 100 CONTINUE 5629C 5630 CALL DZERO(HESSIN,KDIM) 5631 DO 200 ICOOR3 = 1, NCOOR 5632 DO 200 ICOOR2 = 1, NCOOR 5633 DO 200 ICOOR1 = 1, NCOOR 5634 HESSIN(ICOOR1,ICOOR3) = HESSIN(ICOOR1,ICOOR3) 5635 & + TMPHES(ICOOR1,ICOOR2)*SYMCOR(ICOOR2,ICOOR3) 5636 200 CONTINUE 5637 END IF 5638C 5639C *** Print *** 5640C 5641 IF (IPRINT .GT. 7) THEN 5642 CALL HEADER ('Molecular Hessian in ' // TYPE // 5643 & 'coordinates, from TRAHES.', 0) 5644C 5645 N = 0 5646 IF (MOD(NCOOR,6).NE.0) N = 1 5647 NCOL = NCOOR/6 + N 5648 NSTART = 1 5649 NEND = MIN(NCOOR,6) 5650 DO I = 1, NCOL 5651 DO ICOOR1 = 1, NCOOR 5652 WRITE (LUPRI,'(6F14.6)') 5653 & (HESSIN(ICOOR1,ICOOR2), ICOOR2= NSTART, NEND) 5654 END DO 5655 NSTART = NEND + 1 5656 NEND = MIN(NCOOR,NEND+6) 5657 WRITE (LUPRI,'(A)') ' ' 5658 WRITE (LUPRI,'(A)') ' ' 5659 END DO 5660 END IF 5661C 5662 RETURN 5663 END 5664C 5665C /* Deck priprp */ 5666 SUBROUTINE PRIPRP 5667C **************************************** 5668C *** Print routine for analyzing part *** 5669C *** of the numerical derivatives. *** 5670C **************************************** 5671#include "implicit.h" 5672#include "priunit.h" 5673#include "cbinum.h" 5674#include "prpndr.h" 5675C 5676 CALL HEADER('Analysis using the numerical derivatives',0) 5677 WRITE (LUPRI,'(/A/)') ' Properties that are analyzed: ' 5678C 5679 IF (NUMVIB) WRITE (LUPRI,'(A)') 5680 & ' - Frequency analysis and effective geometry.' 5681 IF (NSPNSP) WRITE (LUPRI,'(A)') 5682 & ' - Vibrational average of spin-spin coupling constants' 5683C 5684 RETURN 5685 END 5686C 5687C 5688C /*Deck stppvr*/ 5689 SUBROUTINE STPPVR 5690#include "implicit.h" 5691#include "priunit.h" 5692#include "maxaqn.h" 5693#include "mxcent.h" 5694#include "maxorb.h" 5695C 5696#include "inforb.h" 5697#include "cbiexc.h" 5698#include "pvibav.h" 5699#include "symmet.h" 5700#include "ccexcinf.h" 5701#include "gnrinf.h" 5702C 5703 DODIPS = DIPSTR 5704C 5705C 5706 NTOTEX = 0 5707 DO ISYM = 1, MAXREP+1 5708 IF (DOCCSD) THEN 5709 NTOTEX = NTOTEX + (NCCEXCI(ISYM,1)) 5710 NEXCTB(ISYM) = NCCEXCI(ISYM,1) 5711 ELSE 5712 NTOTEX = NTOTEX + (NEXCIT(ISYM)) 5713 NEXCTB(ISYM) = NEXCIT(ISYM) 5714 END IF 5715 END DO 5716 EXCIT = (NTOTEX.NE.0) 5717C 5718 RETURN 5719 END 5720C 5721C 5722C /*Deck prpder*/ 5723 SUBROUTINE PRPDER(SYMCOR,SPSPDR,COEFF,SPSPFV,TRLNFV,TRLNDR,EXENFV, 5724 & CCPRFV,CCPRDR,GRIREP,WORK,IADRSS,KDPMTX,ICRIRP,INDSTP, 5725 & IDCOMP,IMAX,IMIN,ICNT,NCVAL,IDDCMP,MXCOEF,NTYPE,NPPDER, 5726 & LDPMTX,IFRSTD,NLDPMX,MXNEXI,NSYM,LWORK,IPRINT) 5727#include "implicit.h" 5728#include "priunit.h" 5729#include "mxcent.h" 5730 PARAMETER (DMIN = 1.0D-12, D1=1.0D0, D0=0.0D0) 5731#include "abainf.h" 5732#include "trkoor.h" 5733#include "numder.h" 5734#include "fcsym.h" 5735#include "cbinum.h" 5736#include "pvibav.h" 5737#include "prpc.h" 5738 LOGICAL PRIVAL,CCPRP 5739 DIMENSION COEFF(-MXCOEF:MXCOEF,0:NMRDRP), SYMCOR(NCOOR,NCOOR), 5740 & SPSPDR(NCOOR ,NCOOR,6,NPPDER), GRIREP(NGORDR,NGVERT), 5741 & SPSPFV(NCOOR,NCOOR,6,NMPCAL),EXENFV(NSYM,MXNEXI,NMPCAL), 5742 & TRLNFV(3,NSYM,MXNEXI,NMPCAL), CCPRFV(NPRPC,NMPCAL), 5743 & TRLNDR(3,NSYM,MXNEXI,NPPDER), CCPRDR(NPRPC,NPPDER), 5744 & WORK(LWORK) 5745 DIMENSION ICNT(NTYPE), IADRSS(NTYPE), IMAX(NMRDRP), IMIN(NMRDRP), 5746 & INDSTP(NTORDR), INDTMP(NTORDR), IDCOMP(NCOOR), 5747 & IDDCMP(NCOOR), NCVAL(NCOOR), 5748 & KDPMTX(LDPMTX,NSTRDR,IFRSTD), ICRIRP(NCOOR,2) 5749C 5750C ************************************* 5751C *** Reading properties from file. *** 5752C ************************************* 5753C 5754 KTRAMA = 1 5755 KNREDS = KTRAMA + NMPCAL*NCOOR**2 5756 KEXTMP = KNREDS + NSYM**2 5757 KTRTMP = KEXTMP + NSYM*NTOTEX 5758 KEXERF = KTRTMP + 3*NSYM*NTOTEX 5759 KLAST = KEXERF + NSYM*MXNEXI 5760 LWRK1 = LWORK - KLAST + 1 5761 CALL NDRDPP(SPSPFV,TRLNFV,EXENFV,CCPRFV,WORK(KTRAMA),SYMCOR, 5762 & WORK(KEXTMP),WORK(KTRTMP),WORK(KEXERF), 5763 & WORK(KLAST),WORK(KNREDS),LWRK1,IPRINT,CCPRP) 5764 IF (NPRPDR) CALL GPCLOSE(LUNDPR,'DELETE') 5765 5766c KTRAMA = 1 5767c KLAST = KTRAMA + NMPCAL*NCOOR**2 5768c LWRK1 = LWORK - KLAST + 1 5769c CALL NDRDPP(SPSPFV,TRLNFV,EXENFV,WORK(KTRAMA),SYMCOR,WORK(KLAST), 5770c & LWRK1,IPRINT,DODIPS) 5771c IF (NPRPDR) CALL GPCLOSE(LUNDPR,'DELETE') 5772C 5773C ****************************************** 5774C *** Calculating numerical derivatives. *** 5775C ****************************************** 5776C 5777C *** For cc-properties. *** 5778C 5779 IF (CCPRP) THEN 5780 NFINNR = NPRPC 5781 CALL NMNDER(CCPRDR,COEFF,CCPRFV,GRIREP,WORK,IADRSS,KDPMTX, 5782 & ICRIRP,INDSTP,INDTMP,IDCOMP,IMAX,IMIN,ICNT,NCVAL, 5783 & IDDCMP,MXCOEF,NMRDRP,NMPCAL,NTYPE,NPPDER*NFINNR, 5784 & NFINNR,LDPMTX,IFRSTD,NLDPMX,LWORK,.FALSE.) 5785C 5786C *** Double check sign on excited states property derivatives. *** 5787C 5788 KTPCCD = 1 5789 KTPCCF = KTPCCD + 2*NPRPC*NPPDER 5790 KLAST = KTPCCF + NPRPC*NMPCAL 5791 LWRK1 = LWORK - KLAST + 1 5792 CALL CHK1DR(CCPRFV,CCPRDR,WORK(KTPCCD),WORK(KTPCCF),COEFF, 5793 & GRIREP,WORK(KLAST),ICNT,IADRSS,IMAX,IMIN, 5794 & INDSTP,INDTMP,IDCOMP,IDDCMP,NCVAL,KDPMTX,ICRIRP, 5795 & NPPDER,MXCOEF,NTYPE,NFINNR,LDPMTX,IFRSTD, 5796 & NLDPMX,LWRK1,IPRINT) 5797 END IF 5798C 5799C *** For spin-spin. *** 5800C 5801 IF (SPNSPN) THEN 5802 NFINNR = 6*NCOOR**2 5803 CALL NMNDER(SPSPDR,COEFF,SPSPFV,GRIREP,WORK,IADRSS,KDPMTX, 5804 & ICRIRP,INDSTP,INDTMP,IDCOMP,IMAX,IMIN,ICNT,NCVAL, 5805 & IDDCMP,MXCOEF,NMRDRP,NMPCAL,NTYPE,NPPDER*NFINNR, 5806 & NFINNR,LDPMTX,IFRSTD,NLDPMX,LWORK,.FALSE.) 5807 END IF 5808C 5809C *** For transition dipole moments. *** 5810C 5811 IF (DODIPS) THEN 5812 NFINNR = 3*NSYM*MXNEXI 5813 CALL NMNDER(TRLNDR,COEFF,TRLNFV,GRIREP,WORK,IADRSS,KDPMTX, 5814 & ICRIRP,INDSTP,INDTMP,IDCOMP,IMAX,IMIN,ICNT,NCVAL, 5815 & IDDCMP,MXCOEF,NMRDRP,NMPCAL,NTYPE,NPPDER*NFINNR, 5816 & NFINNR,LDPMTX,IFRSTD,NLDPMX,LWORK,.FALSE.) 5817 END IF 5818C 5819C *********************************************** 5820C *** Write necessary results to file for the *** 5821C *** for the vibrational analysis. *** 5822C *********************************************** 5823C 5824 IF (PRPVIB) THEN 5825 NMDPRP = 0 5826 CALL NDWTPP(SPSPFV,SPSPDR,NPPDER,IPRINT) 5827 END IF 5828C 5829C *********************************** 5830C *** Test print or result print. *** 5831C *********************************** 5832C 5833 IF ((IPRINT.GE.20).OR.(NPRPDR.AND..NOT.PRPVIB)) THEN 5834C 5835C *** For cc-properties. *** 5836C 5837 IF (CCPRP) THEN 5838 IDERV = 0 5839 CALL TITLER('Derivatives OF CC-properties.','*',118) 5840 DO IORDR = 1, NMRDRP 5841 IF (IORDR.EQ.1) THEN 5842 CALL HEADER('1. numerical derivative',0) 5843 DO IC = 1, 2 5844C 5845 IF (IC.EQ.2) THEN 5846 KCDVAL = 1 5847 CALL T1PRSC(CCPRDR,WORK(KCDVAL),SYMCOR,NPRPC, 5848 & NPPDER,IPRINT) 5849 KSTART = KCDVAL 5850 END IF 5851C 5852 DO ICOOR = 1, NDCOOR 5853 IF (IC.EQ.1) THEN 5854 IDERV = IDERV + 1 5855 WRITE (LUPRI,'(5X,A,I5)') 5856 & 'Derivative with respect to ' // 5857 & 'symmetry coordinate', ICOOR 5858 ELSE 5859 WRITE (LUPRI,'(5X,A,I5)') 5860 & 'Derivative with respect to ' // 5861 & 'cartesian coordinate', ICOOR 5862 END IF 5863C 5864 IF (IC.EQ.1) THEN 5865C 5866C *** Update value for printout in *** 5867C *** symmetry coordinates. *** 5868C 5869 LUPRPCO = -1 5870 CALL GPOPEN(LUPRPCO,'CC_PRPC_O','UNKNOWN', 5871 & ' ','FORMATTED',IDUMMY,.FALSE.) 5872 CALL PRPRPC(LUPRPCO,2,CCPRDR(1,IDERV),NPRMI) 5873 CALL GPCLOSE(LUPRPCO,'KEEP') 5874 ELSE 5875C 5876C *** Update value for printout in *** 5877C *** cartesian coordinates. *** 5878C 5879 LUPRPCO = -1 5880 CALL GPOPEN(LUPRPCO,'CC_PRPC_O','UNKNOWN', 5881 & ' ','FORMATTED',IDUMMY,.FALSE.) 5882 CALL PRPRPC(LUPRPCO,2,WORK(KSTART),NPRMI) 5883 CALL GPCLOSE(LUPRPCO,'KEEP') 5884C 5885C *** Update value for printout. *** 5886C 5887 KSTART = KSTART + NPRPC 5888 END IF 5889 WRITE (LUPRI,'(/)') 5890 END DO 5891 END DO 5892 ELSE IF (IORDR.EQ.2) THEN 5893C 5894 CALL HEADER('2. numerical derivative',0) 5895C 5896 DO ICOOR2 = 1, NDCOOR 5897 DO ICOOR1 = 1, ICOOR2 5898C 5899 IDERV = IDERV + 1 5900C 5901 IF (PRPVIB.AND.((NARDRP+NMRDRP).EQ.2)) THEN 5902 PRIVAL = ICOOR1.EQ.ICOOR2 5903 ELSE 5904 PRIVAL = .TRUE. 5905 END IF 5906C 5907 IF (PRIVAL) THEN 5908 WRITE (LUPRI,'(5X,A,I5,A,I5)') 5909 & 'Derivative with respect to coordinate', 5910 & ICOOR2, ' and', ICOOR1 5911C 5912 LUPRPCO = -1 5913 CALL GPOPEN(LUPRPCO,'CC_PRPC_O','UNKNOWN', 5914 & ' ','FORMATTED',IDUMMY,.FALSE.) 5915 CALL PRPRPC(LUPRPCO,2,CCPRDR(1,IDERV),NPRMI) 5916 CALL GPCLOSE(LUPRPCO,'KEEP') 5917 END IF 5918 END DO 5919 END DO 5920 END IF 5921 END DO 5922 END IF 5923C 5924C *** For spin-spin *** 5925C 5926 IF (SPNSPN) THEN 5927 IDERV = 0 5928 CALL TITLER('Spin-spin derivatives.','*',118) 5929 DO IORDR = 1, NMRDRP 5930 IF (IORDR.EQ.1) THEN 5931 CALL HEADER('1. numerical derivative',0) 5932 DO ICOOR = 1, NDCOOR 5933C 5934 IDERV = IDERV + 1 5935C 5936 WRITE (LUPRI,'(5X,A,I5)') 5937 & 'Derivative with respect to coordinate', 5938 & ICOOR 5939C 5940 CALL PRSPSP(SPSPDR(1,1,1,IDERV),NCOOR,NCOOR,LUPRI) 5941 END DO 5942 ELSE IF (IORDR.EQ.2) THEN 5943C 5944 CALL HEADER('2. numerical derivative',0) 5945C 5946 DO ICOOR2 = 1, NDCOOR 5947 DO ICOOR1 = 1, ICOOR2 5948C 5949 IDERV = IDERV + 1 5950C 5951 IF (PRPVIB.AND.((NARDRP+NMRDRP).EQ.2)) THEN 5952 PRIVAL = ICOOR1.EQ.ICOOR2 5953 ELSE 5954 PRIVAL = .TRUE. 5955 END IF 5956C 5957 IF (PRIVAL) THEN 5958 WRITE (LUPRI,'(5X,A,I5,A,I5)') 5959 & 'Derivative with respect to coordinate', 5960 & ICOOR2, ' and', ICOOR1 5961C 5962 CALL PRSPSP(SPSPDR(1,1,1,IDERV),NCOOR,NCOOR, 5963 & LUPRI) 5964 END IF 5965 END DO 5966 END DO 5967 END IF 5968 END DO 5969 END IF 5970C 5971C *** For transition moments *** 5972C 5973 IF (DODIPS) THEN 5974 IDERV = 0 5975 CALL TITLER('Transition moment derivatives.','*',118) 5976 DO IORDR = 1, NMRDRP 5977 IF (IORDR.EQ.1) THEN 5978 CALL HEADER('1. numerical derivative',0) 5979 WRITE (LUPRI,'(5X,A)') 'Excitation energies are' // 5980 & ' shown for original geometry.' 5981 WRITE (LUPRI,'(5X,A)') ' ' 5982 DO ICOOR = 1, NDCOOR 5983C 5984 IDERV = IDERV + 1 5985C 5986 WRITE (LUPRI,'(5X,A,I5)') 5987 & 'Derivative with respect to coordinate', 5988 & ICOOR 5989C 5990 CALL PRDPTR(TRLNDR(1,1,1,IDERV),EXENFV(1,1,1),NSYM, 5991 & LUPRI) 5992 END DO 5993 ELSE IF (IORDR.EQ.2) THEN 5994C 5995 CALL HEADER('2. numerical derivative',0) 5996C 5997 DO ICOOR2 = 1, NDCOOR 5998 DO ICOOR1 = 1, ICOOR2 5999C 6000 IDERV = IDERV + 1 6001C 6002 IF ((PRPVIB).AND.((NARDRP+NMRDRP).EQ.2)) THEN 6003 PRIVAL = ICOOR1.EQ.ICOOR2 6004 ELSE 6005 PRIVAL = .TRUE. 6006 END IF 6007C 6008 IF (PRIVAL) THEN 6009 WRITE (LUPRI,'(5X,A,I5,A,I5)') 6010 & 'Derivative with respect to coordinate', 6011 & ICOOR2, ' and', ICOOR1 6012C 6013 CALL PRDPTR(TRLNDR(1,1,1,IDERV),EXENFV(1,1,1), 6014 & NSYM,LUPRI) 6015 END IF 6016 END DO 6017 END DO 6018 END IF 6019 END DO 6020 END IF 6021 END IF 6022C 6023 RETURN 6024 END 6025C 6026C 6027C /* Deck prspsp */ 6028 SUBROUTINE PRSPSP(SPSPFV,NDIM1,NDIM2,LPRIUN) 6029#include "implicit.h" 6030C 6031 CHARACTER*26 CNTRIB(6) 6032 DIMENSION SPSPFV(NDIM1,NDIM2,6) 6033C 6034C *** Different contributions. *** 6035C 6036 DATA CNTRIB /'Total spin-spin-coupling. ', 6037 & 'DSO-contribution. ', 6038 & 'PSO-contribution. ', 6039 & 'SD-contribution. ', 6040 & 'FC-contribution. ', 6041 & 'Spin dipole Fermi contact.'/ 6042C 6043 NTCOL = NDIM1/3 + 1 6044 IF (MOD(NDIM1,3).EQ.0) NTCOL = NDIM1/3 6045C 6046C *** Printing the contributions. *** 6047C 6048 DO IDIM3 = 1, 6 6049 KDIM = 0 6050 CALL HEADER(CNTRIB(IDIM3),-1) 6051 DO ITCOL = 1, NTCOL 6052 DO IDIM2 = 1, NDIM2 6053 WRITE (LPRIUN,'(3F24.16)') 6054 & (SPSPFV(IDIM1,IDIM2,IDIM3), 6055 & IDIM1 = KDIM+1,MIN(KDIM+3,NDIM1)) 6056 END DO 6057 WRITE (LPRIUN,'(A)') ' ' 6058 KDIM = KDIM + 3 6059 END DO 6060 WRITE (LPRIUN,'(A)') ' ' 6061 END DO 6062C 6063 RETURN 6064 END 6065C 6066C 6067C /* Deck prtrma */ 6068 SUBROUTINE PRTRMA(TRAMAT,NDIMT1,NDIMT2,NDIMP1,NDIMP2,LPRIUN) 6069C ***************************************************************** 6070C *** Subroutine that prints a two dimensional matrix (TRAMAT). *** 6071C ***************************************************************** 6072#include "implicit.h" 6073C 6074 DIMENSION TRAMAT(NDIMT1,NDIMT2) 6075C 6076 NTCOL = NDIMP2/6 + 1 6077 IF (MOD(NDIMP2,6).EQ.0) NTCOL = NDIMP2/6 6078C 6079C *** Printing transformation matrix. *** 6080C 6081 KDIM = 0 6082 DO ITCOL = 1, NTCOL 6083 DO IDIM2 = 1, NDIMP1 6084 WRITE(LPRIUN,'(6F10.4)') 6085 & (TRAMAT(IDIM2,IDIM1),IDIM1 = KDIM+1,MIN(KDIM+6,NDIMP2)) 6086 END DO 6087 WRITE (LPRIUN,'(A)') ' ' 6088 KDIM = KDIM + 6 6089 END DO 6090 WRITE (LPRIUN,'(A)') ' ' 6091C 6092 RETURN 6093 END 6094C 6095C 6096C /* Deck prdptr */ 6097 SUBROUTINE PRDPTR(TRLEN,EXENG,NSYM,LUPRI) 6098C *************************************************** 6099C *** Subroutine that prints the dipole transition*** 6100C *** moments. *** 6101C *************************************************** 6102#include "implicit.h" 6103C 6104#include "cbiexc.h" 6105 DIMENSION TRLEN(3,NSYM,MXNEXI), EXENG(NSYM,MXNEXI) 6106C 6107 CALL HEADER('Electric transition dipole moments (in a.u.)',15) 6108 WRITE (LUPRI,'(1X,A,A,2(/,1X,A))') 6109 & ' Sym. Mode Frequency ', 6110 & ' Length ', 6111 & 'ex. st. No. (au) x y ' // 6112 & ' z ', 6113 & '----------------------------------------------------------' // 6114 & '---------' 6115 DO 200 ISYM = 1, NSYM 6116 DO 100 IEXVAL = 1,NEXCIT(ISYM) 6117 WRITE (LUPRI,'(2X,I2,6X,I3,1X,F12.6,2X,3F13.5)') 6118 & ISYM, IEXVAL, EXENG(ISYM,IEXVAL), 6119 & TRLEN(1,ISYM,IEXVAL), TRLEN(2,ISYM,IEXVAL), 6120 & TRLEN(3,ISYM,IEXVAL) 6121 100 CONTINUE 6122 200 CONTINUE 6123 WRITE (LUPRI,'(///)') 6124C 6125 RETURN 6126 END 6127C 6128C 6129C /* Deck trfcgd */ 6130 SUBROUTINE TRFCGD(EGRAD,SYMCOR,COOR,SEGRAD,WORK,NCOOR1,NCOOR2, 6131 & LWORK,IPRINT) 6132C ************************************************************ 6133C **** Subroutine that transforms a gradient in a set of **** 6134C **** cartesian coordinates, via the permutation of the **** 6135C **** atoms used by the numerical differentiation, to the**** 6136C **** symmetry adapted coordinates used by the numerical **** 6137C **** differentiation scheme. **** 6138C ************************************************************ 6139#include "implicit.h" 6140#include "priunit.h" 6141#include "mxcent.h" 6142 DIMENSION SYMCOR(NCOOR1,NCOOR1), EGRAD(MXCOOR), SEGRAD(NCOOR1), 6143 & COOR(NCOOR1), WORK(LWORK) 6144C 6145C *** Transforming into the "old" set of cartesian *** 6146C *** coordinates. *** 6147C 6148 KCRPRG = 1 6149 KTRAMT = KCRPRG + NCOOR1 6150 CALL TROCGD(EGRAD,COOR,SEGRAD,WORK(KCRPRG),WORK(KTRAMT),NCOOR1, 6151 & IPRINT) 6152C 6153C *** Transforming into symmetry coordinates. *** 6154C 6155 CALL TRSFCG(EGRAD,SYMCOR,SEGRAD,NCOOR1,NCOOR2,IPRINT) 6156C 6157 RETURN 6158 END 6159C 6160C 6161C /* Deck trocgd*/ 6162 SUBROUTINE TROCGD(EGRAD,COOR,TMPGRD,CRTPRG,TRAMAT,NCOOR,IPRINT) 6163C *********************************************************** 6164C **** Subroutine that transforms the gradient in the set**** 6165C **** of cartesian coordinates, to another set of **** 6166C **** cartesian coordinates (stored in coor). **** 6167C *********************************************************** 6168#include "implicit.h" 6169#include "priunit.h" 6170#include "mxcent.h" 6171 PARAMETER (D1 = 1.0D0, D0 = 0.0D0) 6172C 6173 DIMENSION EGRAD (MXCOOR), COOR (NCOOR ), CRTPRG(NCOOR), 6174 & TMPGRD(NCOOR ), TRAMAT(NCOOR,NCOOR) 6175C 6176C *** Constructing the transformation matrix. *** 6177C 6178 CALL TRMTOC(TRAMAT,COOR,CRTPRG,NCOOR,IPRINT) 6179C 6180C *** Transforming the gradient matrix. *** 6181C 6182 CALL DGEMM('N','N',NCOOR,1,NCOOR,D1,TRAMAT,NCOOR,EGRAD,MXCOOR, 6183 & D0,TMPGRD,NCOOR) 6184C 6185 CALL DCOPY(NCOOR,TMPGRD,1,EGRAD,1) 6186C 6187 IF (IPRINT .GT. 20) THEN 6188 CALL HEADER('Test-printing of gradient in new cart. coor.',0) 6189C 6190 WRITE (LUPRI,'(2X,9F12.6)') (EGRAD(I),I=1,NCOOR) 6191 END IF 6192C 6193 RETURN 6194 END 6195C 6196C 6197C /* Deck trsfcg */ 6198 SUBROUTINE TRSFCG(EGRAD,SYMCOR,SEGRAD,NCOOR1,NCOOR2,IPRINT) 6199C *************************************************************** 6200C **** Subroutine that transforms a gradient in the cartesian**** 6201C **** coordinates used by the numerical differentiation, to **** 6202C **** the symmetry adapted coordinates used by the numerical**** 6203C **** differentiation scheme. **** 6204C *************************************************************** 6205#include "implicit.h" 6206#include "priunit.h" 6207#include "mxcent.h" 6208 PARAMETER (D1 = 1.0D0, D0 = 0.0D0) 6209C 6210 DIMENSION SYMCOR(NCOOR1,NCOOR1), EGRAD(MXCOOR), SEGRAD(NCOOR1) 6211C 6212 CALL DGEMM('T','N',NCOOR2,1,NCOOR1,D1,SYMCOR,NCOOR1,EGRAD,MXCOOR, 6213 & D0,SEGRAD,NCOOR1) 6214C 6215 CALL DCOPY(NCOOR2,SEGRAD,1,EGRAD,1) 6216C 6217 IF (IPRINT .GT. 20) THEN 6218 CALL HEADER('Test-printing of gradient in sym. coordinates',0) 6219 WRITE (LUPRI,'(2X,9F12.6)') (SEGRAD(I),I=1,NCOOR2) 6220 END IF 6221C 6222 RETURN 6223 END 6224C 6225C 6226C /* Deck trfchs */ 6227 SUBROUTINE TRFCHS(EHESS,SYMCOR,COOR,SEHESS,WORK,NCOOR1,NCOOR2, 6228 & LWORK,IPRINT) 6229C ************************************************************ 6230C **** Subroutine that transforms a hessian in a set of **** 6231C **** cartesian coordinates, via the permutation of the **** 6232C **** atoms used by the numerical differentiation, to the**** 6233C **** symmetry adapted coordinates used by the numerical **** 6234C **** differentiation scheme. **** 6235C ************************************************************ 6236#include "implicit.h" 6237#include "priunit.h" 6238#include "mxcent.h" 6239 PARAMETER (D1 = 1.0D0, D0 = 0.0D0, KCOL = 6) 6240C 6241 DIMENSION SYMCOR(NCOOR1,NCOOR1), EHESS(MXCOOR,MXCOOR), 6242 & COOR(NCOOR1), SEHESS(NCOOR1,NCOOR1), WORK(LWORK) 6243C 6244C *** Transforming into the "old" set of cartesian *** 6245C *** coordinates. *** 6246C 6247 KCRPRG = 1 6248 KTRAMT = KCRPRG + NCOOR1 6249 CALL TROCHS(EHESS,COOR,SEHESS,WORK(KCRPRG),WORK(KTRAMT),NCOOR1, 6250 & IPRINT) 6251C 6252C *** Transforming into symmetry coordinates. *** 6253C 6254 CALL TRSFC2(EHESS,SYMCOR,SEHESS,NCOOR1,NCOOR2,MXCOOR,IPRINT) 6255C 6256 RETURN 6257 END 6258C 6259C 6260C /* Deck trochs*/ 6261 SUBROUTINE TROCHS(EHESS,COOR,TMPHES,CRTPRG,TRAMAT,NCOOR,IPRINT) 6262C *********************************************************** 6263C **** Subroutine that transforms the hessian in the set **** 6264C **** of cartesian coordinates, to another set of **** 6265C **** cartesian coordinates (stored in coor). **** 6266C *********************************************************** 6267#include "implicit.h" 6268#include "priunit.h" 6269#include "mxcent.h" 6270 PARAMETER (D1 = 1.0D0, D0 = 0.0D0, KCOL = 10) 6271C 6272 INTEGER BEGIN 6273 DIMENSION EHESS (MXCOOR,MXCOOR), COOR(NCOOR), CRTPRG(NCOOR), 6274 & TMPHES(NCOOR ,NCOOR ), TRAMAT(NCOOR ,NCOOR ) 6275C 6276C *** Constructing the transformation matrix. *** 6277C 6278 CALL TRMTOC(TRAMAT,COOR,CRTPRG,NCOOR,IPRINT) 6279C 6280C *** Transforming the hessian matrix. *** 6281C 6282 CALL OTRTEN(EHESS,TRAMAT,TMPHES,MXCOOR,NCOOR,NCOOR,IPRINT,'N','T') 6283C 6284 6285C 6286 IF (IPRINT .GT. 20) THEN 6287 CALL HEADER('Test-printing of hessian in new cart. coor.',0) 6288 BEGIN = 1 6289 LAST = MIN(NCOOR,KCOL) 6290 KCOOR = NCOOR 6291 NCOL = INT(DBLE(NCOOR)/DBLE(KCOL)) 6292 IF (MOD(NCOOR,KCOL).NE.0) NCOL = NCOL + 1 6293C 6294 DO ICOL = 1, NCOL 6295C 6296 DO ICOOR = BEGIN, NCOOR 6297 WRITE (LUPRI,'(2X,9F12.6)') 6298 & (EHESS(ICOOR,I),I=BEGIN,MIN(LAST,ICOOR)) 6299 END DO 6300 WRITE (LUPRI,'()') 6301 BEGIN = BEGIN + KCOL 6302 LAST = MIN(NCOOR,KCOL+LAST) 6303 END DO 6304 6305 END IF 6306 RETURN 6307 END 6308C 6309C 6310C /* Deck trsfc2 */ 6311 SUBROUTINE TRSFC2(SCNDER,SYMCOR,SSCNDR,NCOOR1,NCOOR2,NSCNDR, 6312 & IPRINT) 6313C ************************************************************** 6314C **** Subroutine that transforms a secon derivetive in **** 6315C **** cartesian coordinates used by the numerical **** 6316C **** differentiation, to the symmetry adapted coordinates **** 6317C **** used by the numerical differentiation scheme. **** 6318C ************************************************************** 6319#include "implicit.h" 6320#include "priunit.h" 6321 PARAMETER (D1 = 1.0D0, D0 = 0.0D0, KCOL = 10) 6322C 6323 INTEGER BEGIN, LAST 6324 DIMENSION SYMCOR(NCOOR1,NCOOR1), SCNDER(NSCNDR,NSCNDR), 6325 & SSCNDR(NCOOR1,NCOOR1) 6326C 6327 CALL DGEMM('T','N',NCOOR2,NCOOR1,NCOOR1,D1,SYMCOR,NCOOR1, 6328 & SCNDER,NSCNDR,D0,SSCNDR,NCOOR1) 6329c d = 0.0d0 6330c do i = 1, ncoor1 6331c d = d + SCNDER(1,i)*symcor(i,3) 6332c write (lupri,*) SCNDER(1,i), symcor(i,3) 6333c end do 6334c write (lupri,*) sscndr(3,1),d 6335c stop ' ' 6336C 6337 CALL DGEMM('N','N',NCOOR2,NCOOR2,NCOOR1,D1,SSCNDR,NCOOR1, 6338 & SYMCOR,NCOOR1,D0,SCNDER,NSCNDR) 6339C 6340 IF (IPRINT .GT. 20) THEN 6341 CALL HEADER('Test-printing of hessian in sym. coordinates',0) 6342 BEGIN = 1 6343 LAST = MIN(NCOOR1,KCOL) 6344 KCOOR = NCOOR2 6345 NCOL = NCOOR2/KCOL 6346 IF (MOD(NCOOR2,KCOL).NE.0) NCOL = NCOL + 1 6347C 6348 DO ICOL = 1, NCOL 6349C 6350 DO ICOOR = BEGIN, NCOOR2 6351 WRITE (LUPRI,'(2X,10F12.6)') 6352 & (SCNDER(ICOOR,I),I=BEGIN,MIN(LAST,ICOOR)) 6353 END DO 6354 WRITE (LUPRI,'()') 6355 BEGIN = BEGIN + KCOL 6356 LAST = MIN(NCOOR2,KCOL+LAST) 6357 END DO 6358 END IF 6359C 6360 RETURN 6361 END 6362C 6363C 6364C /* Deck trmtoc */ 6365 SUBROUTINE TRMTOC(TRAMAT,COOR,CRTPRG,NCOOR,IPRINT) 6366C ************************************************************** 6367C **** Subroutine that constructs the transformation matrix **** 6368C **** to transform gradient/hessian back to original **** 6369C **** set of coordinates, defined in COOR. **** 6370C ************************************************************** 6371#include "implicit.h" 6372#include "priunit.h" 6373#include "mxcent.h" 6374#include "maxaqn.h" 6375#include "maxorb.h" 6376 PARAMETER (D1 = 1.0D0, DMTHR=1.0D-4) 6377#include "symmet.h" 6378#include "nuclei.h" 6379#include "pvibav.h" 6380#include "numder.h" 6381#include "cbinum.h" 6382 LOGICAL FOUND 6383 CHARACTER*9 PRPTXT 6384 DIMENSION TRAMAT(NCOOR,NCOOR), COOR(NCOOR), CRTPRG(NCOOR) 6385 6386C 6387C *** Finding the cartesian coordinates used by the *** 6388C *** program at the moment. *** 6389C 6390 ICOOR = 0 6391 IATOM = 0 6392 DO ICENT = 1, NUCIND 6393 MULCNT = ISTBNU(ICENT) 6394 DO IOP = 0, MAXOPR 6395 IF (IAND(IOP,MULCNT) .EQ. 0) THEN 6396 IATOM = IATOM + 1 6397 DO I = 1, 3 6398 ICOOR = ICOOR + 1 6399 CRTPRG(ICOOR) = 6400 & PT(IAND(ISYMAX(I,1),IOP))*CORD(I,ICENT) 6401 END DO 6402 END IF 6403 END DO 6404 END DO 6405C 6406C *** Constructing the transformation matrix by comparing them *** 6407C *** to the old set of cartesian coordinates. *** 6408C 6409 CALL DZERO(TRAMAT,NCOOR**2) 6410 DO IATOM1 = 1, NATOMS 6411 ICS1 = 3*(IATOM1-1) 6412 DO IATOM2 = 1, NATOMS 6413 ICS2 = 3*(IATOM2-1) 6414C 6415 FOUND = .TRUE. 6416 DO IC = 1, 3 6417 FOUND = FOUND .AND. 6418 & ((COOR(ICS1+IC)-CRTPRG(ICS2+IC))**2.LT.DMTHR) 6419 END DO 6420C 6421 IF (FOUND) THEN 6422 DO IC = 1, 3 6423 TRAMAT(ICS1+IC,ICS2+IC) = D1 6424 END DO 6425 END IF 6426 END DO 6427 END DO 6428C 6429C *** If property derivative is calculated, we need to save *** 6430C *** the transformation matrix in the property-file. *** 6431C 6432 IF (CNMPRP) THEN 6433 NDIM3 = 1 6434 PRPTXT = 'CART-TRAN' 6435 CALL WRAVFL(TRAMAT,NCOOR,NCOOR,NDIM3,PRPTXT,IPRINT) 6436 END IF 6437C 6438C *** Test print *** 6439C 6440 IF (IPRINT .GT. 50) THEN 6441 WRITE (LUPRI,'(/A)') 6442 & 'The nuclear coordinates used by the program:' 6443 WRITE (LUPRI,'(9F15.5)') CRTPRG(1:NCOOR) 6444 WRITE (LUPRI,'(/A)') 6445 & 'Transforming to using these nuclear coordinates.' 6446 WRITE (LUPRI,'(9F15.5)') COOR(1:NCOOR) 6447C 6448 WRITE (LUPRI,'(/5X,A/)') 'Transformation matrix:' 6449 CALL PRTRMA(TRAMAT,NCOOR,NCOOR,NCOOR,NCOOR,LUPRI) 6450 END IF 6451C 6452 RETURN 6453 END 6454C 6455C 6456C /* Deck bksmnm */ 6457 SUBROUTINE BKSMNM 6458C **************************************************** 6459C *** This routine takes care of symmetry odds and *** 6460C *** ends connected to frozen core orbitals in *** 6461C *** distorted symmetry. *** 6462C **************************************************** 6463#include "implicit.h" 6464#include "priunit.h" 6465#include "mxcent.h" 6466#include "maxorb.h" 6467#include "maxaqn.h" 6468C 6469#include "symmet.h" 6470#include "nmbksym.h" 6471#include "ccorb.h" 6472#include "numder.h" 6473#include "cbinum.h" 6474 CHARACTER*8 WORD 6475C 6476C *** Backing up symmetry. *** 6477C 6478 CALL ICOPY(64 ,IXVAL ,1,IXVALB,1) 6479 CALL ICOPY(8 ,JSOP ,1,JSOPB ,1) 6480 CALL ICOPY(8 ,NRHFFR ,1,NRHFRB,1) 6481 MAXRPB = MAXREP 6482C 6483C *** Making sure that there are no complicating issues, so *** 6484C *** that the molecule should not rotate freely. *** 6485C 6486 IF (.NOT.NOMOVE) THEN 6487 IF (.NOT.((NAORDR.EQ.0).AND.(NMORDR.NE.1).AND.(.NOT.NPRPDR))) 6488 & NOMOVE = .TRUE. 6489 END IF 6490C 6491C *** Different circumstances where molecule *** 6492C *** is not allowed to rotate. *** 6493C 6494C 6495C *** If symmetry is reported in DALTON.INP *** 6496C *** using .NSYM, no rotation is allowed. *** 6497C 6498 CALL GPOPEN(LUCMD,'DALTON.INP','OLD',' ','FORMATTED',IDUMMY, 6499 & .FALSE.) 6500 ILINE = 0 6501 REWIND (LUCMD,IOSTAT=IOS) 6502 100 CONTINUE 6503 READ (LUCMD,'(A)') WORD 6504 CALL UPCASE(WORD) 6505 IF (WORD .EQ. '.NSYM ') NOMOVE = .TRUE. 6506 IF((WORD .NE. '*END OF ') .AND. 6507 & (WORD .NE. '**END OF')) GOTO 100 6508 CALL GPCLOSE(LUCMD,'KEEP') 6509C 6510C *** Numerical derivatives of properties, *** 6511C *** no rotation is allowed. *** 6512C 6513 IF (NMDPRP.GT.0) NOMOVE = .TRUE. 6514C 6515 RETURN 6516 END 6517C 6518C 6519C /* Deck fndexs */ 6520 SUBROUTINE FNDEXS(WORD,IPRINT) 6521C ****************************************************** 6522C *** Subroutine that sorts out the symmetry of the *** 6523C *** excited states, and assign them to a new irrep *** 6524C *** in the distorted geometry. *** 6525C ****************************************************** 6526#include "implicit.h" 6527#include "priunit.h" 6528#include "mxcent.h" 6529#include "maxorb.h" 6530#include "maxaqn.h" 6531#include "molinp.h" 6532C 6533#include "symmet.h" 6534#include "nmbksym.h" 6535#include "ccorb.h" 6536#include "pgroup.h" 6537 LOGICAL SAMIRP 6538 CHARACTER*(len_MLINE) WORD(KMLINE) 6539C 6540C *** Reducing symmetry of frozen orbitals. *** 6541C 6542 CALL SDCEIP(NRHFFR,NRHFRB,WORD,'.FROINP') 6543C 6544C *** Print. *** 6545C 6546 IF (IPRINT.GT.0) THEN 6547 WRITE (LUPRI,'(/A)') 6548 & 'Symmetries of frozen core orbitals in reduced symmetry:' 6549 WRITE (LUPRI,'(2X,8A4)') (REP(I), I=0,MAXREP) 6550 WRITE (LUPRI,'(8I4)') (NRHFFR(I), I=1,MAXREP+1) 6551 WRITE (LUPRI,'(/)') 6552 END IF 6553C 6554 RETURN 6555 END 6556C 6557C 6558C /* Deck sdceip */ 6559 SUBROUTINE SDCEIP(NCURNT,NBCKUP,WORD,SWORD) 6560C ************************************************************ 6561C *** Subroutine that subduces properties in input file *** 6562C *** from original symmetry into broken symmetry. *** 6563C *** Original symmetry needs to be backed up in nmbksym.h.*** 6564C ************************************************************ 6565#include "implicit.h" 6566#include "priunit.h" 6567#include "mxcent.h" 6568#include "maxorb.h" 6569#include "maxaqn.h" 6570#include "molinp.h" 6571C 6572#include "symmet.h" 6573#include "nmbksym.h" 6574#include "pgroup.h" 6575 LOGICAL SAMIRP 6576 DIMENSION NCURNT(8), NBCKUP(8) 6577 CHARACTER*7 SWORD 6578 CHARACTER*(len_MLINE) WORD(KMLINE) 6579C 6580 CALL STCCSM(NSYM) 6581C 6582 CALL IZERO(NCURNT,8) 6583C 6584C *** Sorting irep's, and assign them to the appropriate *** 6585C *** place in NCURNT. *** 6586C 6587 DO 100 IREP = 0, MAXREP 6588 DO 200 IRPOLD = 0, MAXRPB 6589 IF (NBCKUP(IRPOLD+1) .GT. 0) THEN 6590 SAMIRP = .TRUE. 6591 DO 300 ISYOP2 = 0, MAXREP 6592 DO 300 ISYOP1 = 0, MAXRPB 6593 IF (SYMOP(JSOP(ISYOP2)).EQ.SYMOP(JSOPB(ISYOP1))) THEN 6594 IF (IXVALB(JSOPB(ISYOP1),IRPOLD) .NE. 6595 & IXVAL(JSOP (ISYOP2),IREP )) SAMIRP = .FALSE. 6596 END IF 6597 300 CONTINUE 6598 IF (SAMIRP) THEN 6599 NCURNT(IREP+1) = NCURNT(IREP+1) + NBCKUP(IRPOLD+1) 6600 END IF 6601 END IF 6602 200 CONTINUE 6603 100 CONTINUE 6604C 6605C *** Writing results to DALTON.INP *** 6606C 6607 CALL GPOPEN(LUCMD,'DALTON.INP','OLD',' ','FORMATTED',IDUMMY, 6608 & .FALSE.) 6609C 6610C *** Updating file.*** 6611C 6612 ILINE = 0 6613 REWIND (LUCMD,IOSTAT=IOS) 6614 400 CONTINUE 6615 ILINE = ILINE + 1 6616 READ (LUCMD,'(A)') WORD(ILINE) 6617 CALL UPCASE(WORD(ILINE)) 6618 IF (WORD(ILINE) .EQ. '.NSYM ') THEN 6619 WRITE (WORD(ILINE+1),'(I3)') NSYM 6620 ELSE IF (WORD(ILINE) .EQ. SWORD) THEN 6621 WRITE (WORD(ILINE+1),'(8I4)') (NCURNT(IREP),IREP=1,NSYM) 6622 END IF 6623 IF (.NOT.(WORD(ILINE)(1:6) .EQ. '*END O' .OR. 6624 & WORD(ILINE)(1:6) .EQ. '**END ')) GOTO 400 6625C 6626 REWIND(LUCMD,IOSTAT=IOS) 6627 DO I = 1, ILINE 6628 WRITE (LUCMD,'(A)') WORD(I) 6629 END DO 6630C 6631C *** Closing DALTON.INP. *** 6632C 6633 CALL GPCLOSE(LUCMD,'KEEP') 6634C 6635 RETURN 6636 END 6637C 6638C 6639C /* Deck stccsm */ 6640 SUBROUTINE STCCSM(NSYMCC) 6641#include "implicit.h" 6642#include "priunit.h" 6643C 6644#include "inforb.h" 6645C 6646 NSYMCC = NSYM 6647C 6648 RETURN 6649 END 6650C 6651C 6652C /* Deck wrispc */ 6653 SUBROUTINE WRISPC(FREQ,RNNORM,QUBIC,QUARTC,TXT,NCOOR,NDCOOR,NTIME, 6654 & IPRINT) 6655************************************************************** 6656*** Writes necessary information to DALTON.SPC in order to *** 6657*** run the dal2spectro.pl script. *** 6658************************************************************** 6659#include "implicit.h" 6660#include "priunit.h" 6661 CHARACTER*6 TXT 6662 DIMENSION FREQ(NCOOR), RNNORM(NCOOR), QUBIC(NCOOR,NCOOR,NCOOR), 6663 & QUARTC(NCOOR,NCOOR,NCOOR,NCOOR) 6664C 6665C *** Open DALTON.SPC file. *** 6666C 6667 LSPECT = 0 6668 CALL GPOPEN(LSPECT,'DALTON.SPC','UNKNOWN',' ','FORMATTED',IDUMMY, 6669 & .FALSE.) 6670C 6671C *** NTIME = 1 -> write the frequencies and norm of *** 6672C *** the normal coordinates. *** 6673C *** NTIME = 2 -> write the cubic and quartic force *** 6674C *** field. *** 6675C 6676 IF (NTIME .EQ. 1) THEN 6677C 6678C *** Forwarding to the end of the file if necesary. *** 6679C 6680 IF (TXT(1:6).EQ.'cartes') THEN 6681 KTOT = (NCOOR**3 + 1) + (NCOOR**4 + 1) + 1 6682 DO I = 1, KTOT 6683 READ(LSPECT,*) 6684 END DO 6685 ELSE 6686 WRITE (LSPECT,*) TXT(1:6) 6687 END IF 6688C 6689C *** Writing frequencies. *** 6690C 6691 WRITE (LSPECT,*) 'Frequencies' 6692 DO I = 1, NDCOOR 6693 WRITE (LSPECT,'(F18.10)') FREQ(I) 6694 END DO 6695C 6696C *** Writing norm of normal coordinates. *** 6697C 6698 WRITE (LSPECT,*) 'Coordinate norm' 6699 DO I = 1, NDCOOR 6700 WRITE (LSPECT,'(F18.10)') RNNORM(I) 6701 END DO 6702 ELSE IF (NTIME .EQ. 2) THEN 6703C 6704C *** Forwarding to the end of the file if necesary. *** 6705C 6706 IF (TXT(1:6).EQ.'normal') THEN 6707 KTOT = 2*NDCOOR + 3 6708 DO I = 1, KTOT 6709 READ(LSPECT,*) 6710 END DO 6711 ELSE 6712 WRITE (LSPECT,*) TXT(1:6) 6713 END IF 6714C 6715C *** Writing cubic force field. *** 6716C 6717 WRITE (LSPECT,*) 'Cubic force field' 6718 DO 100 K = 1, NDCOOR 6719 DO 100 J = 1, NDCOOR 6720 DO 100 I = 1, NDCOOR 6721 WRITE (LSPECT,*) QUBIC(I,J,K), I, J, K 6722 100 CONTINUE 6723C 6724C *** Writing quartic force field. *** 6725C 6726 WRITE (LSPECT,*) 'Quartic force field' 6727 DO 200 L = 1, NDCOOR 6728 DO 200 K = 1, NDCOOR 6729 DO 200 J = 1, NDCOOR 6730 DO 200 I = 1, NDCOOR 6731 WRITE (LSPECT,*) QUARTC(I,J,K,L), I, J, K, L 6732 200 CONTINUE 6733 END IF 6734C 6735C *** CLOSING FILE. *** 6736C 6737 CALL GPCLOSE(LSPECT,'KEEP') 6738C 6739 RETURN 6740 END 6741C 6742C 6743C /* Deck runpnt */ 6744 LOGICAL FUNCTION RUNPNT(CLNRGY,IWIDTH,IDIME) 6745C ********************************************************* 6746C *** Subroutine that checks if this is a *** 6747C *** point we need to calculate. *** 6748C *** There are several criteria: *** 6749C *** CLNRGY = .FALSE. -> need not to calculate because *** 6750C *** of symmetry. *** 6751C *** (ANALZ1 = .TRUE.) & (NMORDR=IWIDTH=3) -> Need only*** 6752C *** the diagonal cubic force and *** 6753C *** this point contributes to *** 6754C *** F(I,J,K), I ne J ne K. *** 6755C ********************************************************* 6756#include "implicit.h" 6757#include "priunit.h" 6758 LOGICAL RNPNT1, CLNRGY 6759#include "numder.h" 6760#include "cbinum.h" 6761C 6762C *** Original geometry is always calculated. *** 6763C 6764 IF (IDIME.EQ.1) THEN 6765 RNPNT1 = .TRUE. 6766 ELSE 6767C 6768C *** Initializing. *** 6769C 6770 RNPNT1 = CLNRGY 6771C 6772C *** Is this a ANALZ1 vibrational average. *** 6773C 6774 IF (RNPNT1.AND.ANALZ1.AND.NRMCRD.AND.(NMORDR.EQ.IWIDTH)) THEN 6775C 6776C *** NMORDR+NAORDR = 3 -> The forcefield we need to do in *** 6777C *** ANALZ1. *** 6778C *** NMORDR-NAORDR > 1 -> Don't need this point for property *** 6779C *** derivatives. *** 6780C 6781 IF ((NAORDR.LT.2) .AND. ((NMORDR+NAORDR).EQ.3)) THEN 6782 RNPNT1 = .FALSE. 6783 END IF 6784 END IF 6785 END IF 6786C 6787 RUNPNT = RNPNT1 6788C 6789 RETURN 6790 END 6791C 6792C 6793C /* Deck srtins*/ 6794 SUBROUTINE SRTINS(INDSTP,INDTMP) 6795C ***************************************************************** 6796C *** Subroutine that sorts three indices, where two indices *** 6797C *** are equal, so that the one index not equal the two others *** 6798C *** are put first. The indices are returned in INDTMP. *** 6799C ***************************************************************** 6800#include "implicit.h" 6801#include "priunit.h" 6802 LOGICAL EQUAL, FOUND 6803 INTEGER INDSTP(3), INDTMP(3) 6804 INTEGER ITMP(3) 6805C 6806 FOUND = .FALSE. 6807C 6808 DO J = 1, 3 6809 IF (.NOT.FOUND) THEN 6810 EQUAL = .FALSE. 6811C 6812 DO I = 1, 3 6813 IF (I.NE.J) THEN 6814 IF (INDSTP(J).EQ.INDSTP(I)) THEN 6815 EQUAL = .TRUE. 6816 END IF 6817 END IF 6818 END DO 6819C 6820 IF (.NOT.EQUAL) THEN 6821 IJ = 0 6822 ITMP(3) = INDSTP(J) 6823 DO I = 1, 3 6824 IF (I.NE.J) THEN 6825 IJ = IJ + 1 6826 ITMP(IJ) = INDSTP(I) 6827 END IF 6828 END DO 6829 FOUND = .TRUE. 6830 CALL ICOPY(3,ITMP,1,INDTMP,1) 6831 END IF 6832 END IF 6833 END DO 6834C 6835 IF (.NOT.FOUND) THEN 6836 CALL ICOPY(3,INDSTP,1,INDTMP,1) 6837 END IF 6838C 6839 RETURN 6840 END 6841C 6842C 6843C /* Deck prexce */ 6844 SUBROUTINE PREXCE(EXENG,NSYM,LUPRI) 6845C ************************************************** 6846C *** Subroutine that prints excitation energies *** 6847C ************************************************** 6848#include "implicit.h" 6849#include "codata.h" 6850#include "cbiexc.h" 6851 DIMENSION EXENG(NSYM,MXNEXI) 6852C 6853 IF (EXCTRP) THEN 6854 CALL HEADER('Triplet electronic excitation energies',15) 6855 ELSE 6856 CALL HEADER ('Singlet electronic excitation energies',15) 6857 END IF 6858C 6859 WRITE (LUPRI,'(14X,A,/,14X,A,/,14X,A)') 6860 & ' Sym. Mode Frequency Frequency', 6861 & 'ex. st. No. (au) (eV)', 6862 & '---------------------------------------' 6863 DO 15 ISYM = 1, NSYM 6864 DO 14 IEXVAL = 1, NEXCIT(ISYM) 6865 WRITE (LUPRI,'(16X,I2,6X,I3,2F12.6)') 6866 & ISYM,IEXVAL,EXENG(ISYM,IEXVAL), 6867 & EXENG(ISYM,IEXVAL)*XTEV 6868 14 CONTINUE 6869 15 CONTINUE 6870C 6871 WRITE (LUPRI,'(//)') 6872C 6873 RETURN 6874 END 6875C 6876C 6877C /* Deck chksgn */ 6878 SUBROUTINE CHKSGN(TRLNFV,IPRINT) 6879C ************************************************************* 6880C *** Subroutine that checks if the phase of the components *** 6881C *** of the transition dipole moment is correct. *** 6882C ************************************************************* 6883#include "implicit.h" 6884#include "priunit.h" 6885#include "mxcent.h" 6886#include "maxorb.h" 6887#include "maxaqn.h" 6888 PARAMETER (THRSH=1.0D-8) 6889#include "inforb.h" 6890#include "cbiexc.h" 6891#include "pvibav.h" 6892#include "symmet.h" 6893#include "numder.h" 6894 DIMENSION TRLNFV(3,NSYM,MXNEXI,NMPCAL) 6895C 6896 DO 100 IMPCAL = 1, NMPCAL 6897 CALL NMCOMP(NFIRST,IMPCAL,NMRDRP,IPRINT) 6898C 6899 DO 200 ISYM = 1, MAXREP+1 6900 DO 200 IEXVAL = 1, NEXCTB(ISYM) 6901 DO 200 IC = 1, 3 6902 TADD =(TRLNFV(IC,ISYM,IEXVAL,IMPCAL) 6903 & + TRLNFV(IC,ISYM,IEXVAL,NFIRST))**2 6904 TSUB =(TRLNFV(IC,ISYM,IEXVAL,IMPCAL) 6905 & - TRLNFV(IC,ISYM,IEXVAL,NFIRST))**2 6906C 6907C *** Checking if there has been a change of sign. *** 6908C 6909 IF (ABS(TRLNFV(IC,ISYM,IEXVAL,1)).GT.THRSH) THEN 6910 IF (TADD.LT.TSUB) THEN 6911 TRLNFV(IC,ISYM,IEXVAL,IMPCAL) = 6912 & - TRLNFV(IC,ISYM,IEXVAL,IMPCAL) 6913 END IF 6914 ELSE 6915 IF (TSUB.LT.TADD) THEN 6916 TRLNFV(IC,ISYM,IEXVAL,IMPCAL) = 6917 & - TRLNFV(IC,ISYM,IEXVAL,IMPCAL) 6918 END IF 6919 END IF 6920 200 CONTINUE 6921 100 CONTINUE 6922C 6923 RETURN 6924 END 6925C 6926C 6927C /* Deck chkccs */ 6928 SUBROUTINE CHKCCS(TRLNFV,IPRINT) 6929C ************************************************************* 6930C *** Subroutine that checks if the phase of the components *** 6931C *** of the cc transition dipole moment is correct. *** 6932C ************************************************************* 6933#include "implicit.h" 6934#include "priunit.h" 6935 PARAMETER (THRESH=1.0D-10) 6936#include "numder.h" 6937#include "prpc.h" 6938 DIMENSION TRLNFV(NPRPC,NMPCAL) 6939 CHARACTER LABEL*10, LABX*8, LABY*8, LABZ*8, LABU*8 6940C 6941 LUPRPCO = -1 6942 CALL GPOPEN(LUPRPCO,'CC_PRPC_O','UNKNOWN',' ','FORMATTED', 6943 * IDUMMY,.FALSE.) 6944C 6945 REWIND(LUPRPCO) 6946 DO IPRPC = 1, NPRPC 6947C 6948C Read in info on property 6949C 6950 READ(LUPRPCO, 6951 * '(I5,I3,I4,1X,A10,1P,E23.16,4(1X,A8),3E23.16,3I4)') 6952 * IPRPC2,ISYMIN,NORD,LABEL,PROP, 6953 * LABX,LABY,LABZ,LABU,FRQY,FRQZ,FRQU,ISYEX,ISPEX,IEX 6954 IF (IPRPC.NE.IPRPC2) CALL QUIT( 'Strange stuff in CHKCCS') 6955C 6956 IF (NORD .EQ.-1) THEN 6957C 6958 TRLNFV(IPRPC,1) = ABS(TRLNFV(IPRPC,1)) 6959C 6960 DO IMPCAL = 2, NMPCAL, 2 6961 6962 TADD=(TRLNFV(IPRPC,IMPCAL)+TRLNFV(IPRPC,IMPCAL+1))**2 6963 TSUB=(TRLNFV(IPRPC,IMPCAL)-TRLNFV(IPRPC,IMPCAL+1))**2 6964C 6965 IF (ISYMIN .NE.1) THEN 6966 IF (TSUB.LT.TADD) THEN 6967 TRLNFV(IPRPC,IMPCAL) = -TRLNFV(IPRPC,IMPCAL) 6968 END IF 6969 ELSE 6970 IF (ABS(TRLNFV(IPRPC,1)).LT.THRESH) THEN 6971 IF (TSUB.LT.TADD) THEN 6972 TRLNFV(IPRPC,IMPCAL) = -TRLNFV(IPRPC,IMPCAL) 6973 END IF 6974 ELSE 6975 IF (TADD.LT.TSUB) THEN 6976 TRLNFV(IPRPC,IMPCAL) = -TRLNFV(IPRPC,IMPCAL) 6977 END IF 6978 END IF 6979 END IF 6980 END DO 6981 END IF 6982 END DO 6983 CALL GPCLOSE(LUPRPCO,'KEEP') 6984C 6985 RETURN 6986 END 6987C 6988C 6989C /* Deck nmcomp */ 6990 SUBROUTINE NMCOMP(NFIRST,IMPCAL,NORDR,IPRINT) 6991C *********************************************************** 6992C *** Subroutine that recognizes the first function value *** 6993C *** of a derivative and returns this in NFIRST. *** 6994C *********************************************************** 6995#include "implicit.h" 6996#include "priunit.h" 6997#include "mxcent.h" 6998C 6999#include "trkoor.h" 7000 LOGICAL DONE 7001C 7002C *** Init. *** 7003C 7004 DONE = .FALSE. 7005C 7006 IDSTRT = 0 7007 DO IORDR = 1, NORDR 7008C 7009 IADD = 1 7010 DO I = 1, IORDR 7011 IADD = IADD*2*(NCOOR-I+1)/I 7012 END DO 7013 IDSTRT = IDSTRT + IADD 7014C 7015C *** Test that this is a derivative of order iordr. *** 7016C *** We need to remove the first point since this *** 7017C *** does not contribute to any derivative. *** 7018C 7019 IF ((IMPCAL-1.LE.IDSTRT).AND.(.NOT.DONE)) THEN 7020 DONE = .TRUE. 7021C 7022C *** Number of calculation points for this *** 7023C *** derivative *** 7024C 7025 IPNTS = 2**IORDR 7026C 7027C *** This is point number: *** 7028C 7029 IDNUM = IMPCAL-2 - (IDSTRT-IADD) 7030 KPNT = MOD(IDNUM,IPNTS) 7031C 7032C *** First point for this derivative is: *** 7033C 7034 NFIRST = IMPCAL - KPNT 7035C 7036 END IF 7037 END DO 7038C 7039 RETURN 7040 END 7041C 7042C 7043C /* Deck cke1dr */ 7044 SUBROUTINE CHK1DR(CCPRFV,CCPRDR,TMPCCD,TMPCCF,COEFF,GRIREP, 7045 & WORK,ICNT,IADRSS,IMAX,IMIN,INDSTP,INDTMP, 7046 & IDCOMP,IDDCMP,NCVAL,KDPMTX,ICRIRP,NPPDER,MXCOEF, 7047 & NTYPE,NFINNR,LDPMTX,IFRSTD,NLDPMX,LWORK,IPRINT) 7048C ********************************************************** 7049C *** Subroutine that calculates two other possible *** 7050C *** derivatives for the first derivative of transition *** 7051C *** dipole moment. This is to check if there is a sign *** 7052C *** problem in the molecular system. *** 7053C ********************************************************** 7054#include "implicit.h" 7055#include "priunit.h" 7056#include "mxcent.h" 7057C 7058#include "prpc.h" 7059#include "numder.h" 7060#include "fcsym.h" 7061#include "trkoor.h" 7062 DIMENSION CCPRFV(NPRPC,NMPCAL), CCPRDR(NPRPC,NPPDER ), 7063 & TMPCCF(NPRPC,NMPCAL), TMPCCD(NPRPC,NPPDER,2), 7064 & COEFF(-MXCOEF:MXCOEF,0:NMRDRP),GRIREP(NGORDR,NGVERT), 7065 & WORK(LWORK) 7066 DIMENSION ICNT(NTYPE), IADRSS(NTYPE), IMAX(NMRDRP), IMIN(NMRDRP), 7067 & INDSTP(NTORDR), INDTMP(NTORDR), IDCOMP(NCOOR), 7068 & IDDCMP(NCOOR),NCVAL(NCOOR),KDPMTX(LDPMTX,NSTRDR,IFRSTD), 7069 & ICRIRP(NCOOR,2) 7070C 7071 CHARACTER LABEL*10, LABX*8, LABY*8, LABZ*8, LABU*8 7072C 7073C *** First option, reversing the sign on the last value. *** 7074C *** df/dx = f(+)-(-f(-)). *** 7075C 7076C *** Assigning new function values. *** 7077C 7078 IMPCAL = 1 7079 DO ICOOR = 1, NCOOR 7080 IMPCAL = IMPCAL + 1 7081 DO IPRPC = 1, NPRPC 7082 TMPCCF(IPRPC,IMPCAL) = CCPRFV(IPRPC,IMPCAL) 7083 END DO 7084 IMPCAL = IMPCAL + 1 7085 DO IPRPC = 1, NPRPC 7086 TMPCCF(IPRPC,IMPCAL) = -CCPRFV(IPRPC,IMPCAL) 7087 END DO 7088 END DO 7089C 7090C *** Finding the new derivative. *** 7091C 7092 NFINNR = NPRPC 7093 CALL NMNDER(TMPCCD(1,1,1),COEFF,TMPCCF,GRIREP,WORK,IADRSS,KDPMTX, 7094 & ICRIRP,INDSTP,INDTMP,IDCOMP,IMAX,IMIN,ICNT,NCVAL, 7095 & IDDCMP,MXCOEF,1,NMPCAL,NTYPE,NPPDER*NFINNR,NFINNR, 7096 & LDPMTX,IFRSTD,NLDPMX,LWORK,.FALSE.) 7097C 7098C *** Second option, two, point formula *** 7099C *** df/dx = f(+)-f(0). *** 7100C 7101C *** Assigning new function values. *** 7102C 7103 IMPCAL = 1 7104 DO ICOOR = 1, NCOOR 7105 IMPCAL = IMPCAL + 1 7106 DO IPRPC = 1, NPRPC 7107 TMPCCF(IPRPC,IMPCAL) = CCPRFV(IPRPC,IMPCAL) 7108 END DO 7109 IMPCAL = IMPCAL + 1 7110 DO IPRPC = 1, NPRPC 7111 TMPCCF(IPRPC,IMPCAL) = CCPRFV(IPRPC,1) 7112 END DO 7113 END DO 7114C 7115C *** Finding the new derivative. *** 7116C 7117 NFINNR = NPRPC 7118 CALL NMNDER(TMPCCD(1,1,2),COEFF,TMPCCF,GRIREP,WORK,IADRSS, 7119 & KDPMTX,ICRIRP,INDSTP,INDTMP,IDCOMP,IMAX,IMIN,ICNT, 7120 & NCVAL, 7121 & IDDCMP,MXCOEF,1,NMPCAL,NTYPE,NPPDER*NFINNR, 7122 & NFINNR,LDPMTX,IFRSTD,NLDPMX,LWORK,.FALSE.) 7123C 7124 LUPRPCO = -1 7125 CALL GPOPEN(LUPRPCO,'CC_PRPC_O','UNKNOWN',' ','FORMATTED', 7126 * IDUMMY,.FALSE.) 7127C 7128 DO ICOOR = 1, NCOOR 7129 CALL AROUND ('Checking derivative with respect to new' // 7130 & ' coordinate') 7131 WRITE (LUPRI,'(A,I4)') 'Coordinate number', ICOOR 7132 REWIND(LUPRPCO) 7133 WRITE (LUPRI,'(36X,A)') ' Best guess Second choice' // 7134 & ' Two point formula' 7135 DO IPRPC = 1, NPRPC 7136 READ(LUPRPCO, 7137 * '(I5,I3,I4,1X,A10,1P,E23.16,4(1X,A8),3E23.16,3I4)') 7138 * IPRPC2,ISYMIN,NORD,LABEL,PROP, 7139 * LABX,LABY,LABZ,LABU,FRQY,FRQZ,FRQU,ISYEX,ISPEX,IEX 7140 IF (IPRPC.NE.IPRPC2) CALL QUIT( 'Strange stuff in CHK1DR') 7141 IF (NORD .EQ.-1) THEN 7142 WRITE(LUPRI, 7143 & '(I2,A,A8,A3,F9.6,A,3X,F14.7,3X,F14.7,3X,F14.7)') 7144 & ISYMIN,' |<O|',LABX,'|i(',FRQY,')>|', 7145 & CCPRDR(IPRPC,ICOOR), TMPCCD(IPRPC,ICOOR,1), 7146 & 2.0D0*TMPCCD(IPRPC,ICOOR,2) 7147 END IF 7148 END DO 7149 END DO 7150C 7151 CALL GPCLOSE(LUPRPCO,'KEEP') 7152C 7153 RETURN 7154 END 7155C 7156C 7157C /* Deck trprsc*/ 7158 SUBROUTINE T1PRSC(DVAL,CDVAL,SYMCOR,NDIM1,NDERV,IPRINT) 7159#include "implicit.h" 7160#include "priunit.h" 7161#include "mxcent.h" 7162 PARAMETER (D1=1.0D0, D0=0.0D0) 7163#include "trkoor.h" 7164 DIMENSION DVAL(NDIM1,NDERV), SYMCOR(NCOOR,NCOOR), 7165 & CDVAL(NDIM1,NCOOR) 7166C 7167 CALL DZERO(CDVAL,NDIM1*NCOOR) 7168 DO ICOOR2 = 1, NCOOR 7169 DO ICOOR1 = 1, NCOOR 7170 DO IINNER = 1, NDIM1 7171 CDVAL(IINNER,ICOOR1) = CDVAL(IINNER,ICOOR1) 7172 & + SYMCOR(ICOOR1,ICOOR2)*DVAL(IINNER,ICOOR2) 7173 END DO 7174 END DO 7175 END DO 7176C 7177 RETURN 7178 END 7179 7180C 7181C 7182C /* Deck wrimop */ 7183 SUBROUTINE WRIMOP(FREQ,RNNORM,QUBIC,QUARTC,TXT,NCOOR,NDCOOR,NTIME, 7184 & IPRINT) 7185************************************************************** 7186*** Writes necessary information to DALTON.MOP : *** 7187*** An operator file to be read in by MidasCpp *** 7188*** Ove Christiansen based on Torgeirs WRISPC 7189*** At this stage it makes only sense with norm. coord. 7190************************************************************** 7191#include "implicit.h" 7192#include "priunit.h" 7193#include "cbinum.h" 7194 CHARACTER*6 TXT 7195 DIMENSION FREQ(NCOOR), RNNORM(NCOOR), QUBIC(NCOOR,NCOOR,NCOOR), 7196 & QUARTC(NCOOR,NCOOR,NCOOR,NCOOR) 7197 LOGICAL USESYM 7198 SAVE FRQLAR 7199 USESYM = .TRUE. 7200 7201 NTOT = 0 7202 NWRIT = 0 7203 THRTRM = 0.0D0 7204C 7205C *** Open DALTON.MOP file. *** 7206C Only for normal coordinates right now. 7207C 7208 IF (TXT(1:6).EQ.'normal') THEN 7209C IF ((NTIME.EQ.2).OR.(NTIME.EQ.1 .AND. 7210 7211 WRITE(LUPRI,'(A)') " WRITE TO MIDAS INTERFACE FILE, " 7212 & //"DALTON.MOP " 7213 LMIDAS = 0 7214 CALL GPOPEN(LMIDAS,'DALTON.MOP','UNKNOWN',' ','FORMATTED', 7215 & IDUMMY,.FALSE.) 7216 ELSE 7217 RETURN 7218 ENDIF 7219C 7220C *** NTIME = 1 -> write the frequencies 7221C *** NTIME = 2 -> write the cubic and quartic force field. 7222C 7223C 7224 FAC = 0.5D0 7225 IF (NTIME .EQ. 1) THEN 7226C 7227 IF (TXT(1:6).EQ.'normal') THEN 7228 WRITE (LMIDAS,*) "DALTON_FOR_MIDAS " 7229C 7230C *** Writing frequencies. *** 7231C 7232C WRITE (LMIDAS,*) 'Frequencies' 7233 DO I = 1, NDCOOR 7234 WRITE (LMIDAS,'(1P,E23.16,2I6)') 7235 * FAC*FREQ(I)*FREQ(I),I,I 7236c WRITE (LMIDAS,'(F18.10)') FREQ(I) 7237 END DO 7238C 7239C Find largest frequency. 7240C 7241 FRQLAR=0.0D0 7242 DO I = 1, NDCOOR 7243 IF (ABS(FREQ(I)).GT.FRQLAR) FRQLAR = FREQ(I) 7244 END DO 7245C 7246C ELSE 7247C RETURN 7248 END IF 7249C 7250C 7251 ELSE IF (NTIME .EQ. 2) THEN 7252C 7253C 7254C *** Forwarding to the end of the file if necesary. *** 7255 7256 IF (TXT(1:6).EQ.'normal') THEN 7257 KTOT = NDCOOR + 1 7258 DO I = 1, KTOT 7259 READ(LMIDAS,*) 7260 END DO 7261 ELSE 7262 RETURN 7263 END IF 7264C 7265C Prepare screening and count of significant terms 7266C Threshold: do not write out things that are 7267C THRMID times smaller than the larges frequency. 7268C 7269 NTOT = NDCOOR 7270 NWRIT = NDCOOR 7271 THRTRM = FAC*FRQLAR*FRQLAR*THRMID 7272C WRITE(LUPRI,'(A,1P,E23.16)') " FRQLAR " ,FRQLAR 7273C WRITE(LUPRI,'(A,1P,E23.16)') " FAC " ,FAC 7274C WRITE(LUPRI,'(A,1P,E23.16)') " THRMID " ,THRMID 7275C WRITE(LUPRI,'(A,1P,E23.16)') " THRTRM " ,THRTRM 7276C 7277C *** Writing cubic force field. *** 7278C Note scaling with norms and symmetry factors! 7279C 7280C WRITE (LMIDAS,*) 'Cubic force field' 7281 SUM_QUANT = 0.0D0 7282 IF (.NOT.USESYM) THEN 7283 FAC=1.0D0/6.0D0 7284 DO 100 K = 1, NDCOOR 7285 DO 100 J = 1, NDCOOR 7286 DO 100 I = 1, NDCOOR 7287 QUANT = FAC*QUBIC(I,J,K)*RNNORM(I)*RNNORM(J)*RNNORM(K) 7288 NTOT=NTOT+1 7289 IF (ABS(QUANT).GE.THRTRM) THEN 7290 7291 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7292 WRITE (LMIDAS,'(1P,E23.16,3I6)') 7293 * QUANT, I, J, K 7294 NWRIT=NWRIT+1 7295 ENDIF 7296 100 CONTINUE 7297C 7298C *** Writing quartic force field. *** 7299C 7300C WRITE (LMIDAS,*) 'Quartic force field' 7301 FAC=1.0D0/24.0D0 7302 DO 200 L = 1, NDCOOR 7303 DO 200 K = 1, NDCOOR 7304 DO 200 J = 1, NDCOOR 7305 DO 200 I = 1, NDCOOR 7306 QUANT = FAC*QUARTC(I,J,K,L)*RNNORM(I)*RNNORM(J)* 7307 * RNNORM(K)*RNNORM(L) 7308 NTOT=NTOT+1 7309 IF (ABS(QUANT).GE.THRTRM) THEN 7310 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7311 WRITE (LMIDAS,'(1P,E23.16,4I6)') 7312 * QUANT,I, J, K, L 7313 NWRIT=NWRIT+1 7314 ENDIF 7315 200 CONTINUE 7316 ELSE 7317C one mode 7318 FAC=1.0D0/6.0D0 7319 DO 110 I = 1, NDCOOR 7320 QUANT = FAC*QUBIC(I,I,I)*RNNORM(I)*RNNORM(I)*RNNORM(I) 7321 NTOT=NTOT+1 7322 IF (ABS(QUANT).GE.THRTRM) THEN 7323 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7324 WRITE (LMIDAS,'(1P,E23.16,3I6)') 7325 * QUANT, I, I, I 7326 NWRIT=NWRIT+1 7327 ENDIF 7328 110 CONTINUE 7329 FAC=1.0D0/24.0D0 7330 DO 210 I = 1, NDCOOR 7331 NTOT=NTOT+1 7332 QUANT = FAC*QUARTC(I,I,I,I)*RNNORM(I)*RNNORM(I)* 7333 * RNNORM(I)*RNNORM(I) 7334 IF (ABS(QUANT).GE.THRTRM) THEN 7335 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7336 WRITE (LMIDAS,'(1P,E23.16,4I6)') 7337 * QUANT,I,I,I,I 7338 NWRIT=NWRIT+1 7339 ENDIF 7340 210 CONTINUE 7341C two mode coupling 7342 FAC=1.0D0/2.0D0 7343 DO 120 J = 1, NDCOOR 7344 DO 120 I = 1, NDCOOR 7345 IF (I.NE.J) THEN 7346 NTOT=NTOT+1 7347 QUANT = FAC*QUBIC(I,J,J)*RNNORM(I) 7348 * *RNNORM(J)*RNNORM(J) 7349 IF (ABS(QUANT).GE.THRTRM) THEN 7350 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7351 WRITE (LMIDAS,'(1P,E23.16,3I6)') 7352 * QUANT, I, J, J 7353 7354 NWRIT=NWRIT+1 7355 ENDIF 7356 ENDIF 7357 120 CONTINUE 7358 FAC=1.0D0/4.0D0 7359 DO 220 J = 1, NDCOOR 7360 DO 220 I = 1, J-1 7361 NTOT=NTOT+1 7362 QUANT = FAC*QUARTC(I,I,J,J)*RNNORM(I)*RNNORM(I)* 7363 * RNNORM(J)*RNNORM(J) 7364 IF (ABS(QUANT).GE.THRTRM) THEN 7365 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7366 WRITE (LMIDAS,'(1P,E23.16,4I6)') 7367 * QUANT, I, I, J, J 7368 NWRIT=NWRIT+1 7369 ENDIF 7370 220 CONTINUE 7371 FAC=1.0D0/6.0D0 7372 DO 221 J = 1, NDCOOR 7373 DO 221 I = 1, NDCOOR 7374 IF (I.NE.J) THEN 7375 NTOT=NTOT+1 7376 QUANT = FAC*QUARTC(I,J,J,J)*RNNORM(I)*RNNORM(J)* 7377 * RNNORM(J)*RNNORM(J) 7378 IF (ABS(QUANT).GE.THRTRM) THEN 7379 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7380 WRITE (LMIDAS,'(1P,E23.16,4I6)') QUANT,I,J,J,J 7381 NWRIT=NWRIT+1 7382 ENDIF 7383 ENDIF 7384 221 CONTINUE 7385C three mode coupling 7386 FAC=1.0D0 7387 DO 130 K = 1, NDCOOR 7388 DO 130 J = 1, K-1 7389 DO 130 I = 1, J-1 7390 NTOT=NTOT+1 7391 QUANT = FAC*QUBIC(I,J,K)*RNNORM(I)*RNNORM(J)*RNNORM(K) 7392 IF (ABS(QUANT).GE.THRTRM) THEN 7393 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7394 WRITE (LMIDAS,'(1P,E23.16,3I6)') QUANT,I,J,K 7395 NWRIT=NWRIT+1 7396 ENDIF 7397 130 CONTINUE 7398 FAC=1.0D0/2.0D0 7399 DO 230 K = 1, NDCOOR 7400 DO 230 J = 1, K-1 7401 DO 230 I = 1, NDCOOR 7402 IF ((I.NE.J).AND.(I.NE.K)) THEN 7403 NTOT=NTOT+1 7404 QUANT = FAC*QUARTC(I,I,J,K)*RNNORM(I)*RNNORM(I)* 7405 * RNNORM(J)*RNNORM(K) 7406 IF (ABS(QUANT).GE.THRTRM) THEN 7407 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7408 WRITE (LMIDAS,'(1P,E23.16,4I6)') 7409 * QUANT, I, I, J, K 7410 NWRIT=NWRIT+1 7411 ENDIF 7412 ENDIF 7413 230 CONTINUE 7414C 7415C four mode coupling 7416 FAC=1.0D0 7417 DO 240 L = 1, NDCOOR 7418 DO 240 K = 1, L-1 7419 DO 240 J = 1, K-1 7420 DO 240 I = 1, J-1 7421 NTOT=NTOT+1 7422 QUANT = FAC*QUARTC(I,J,K,L)*RNNORM(I)*RNNORM(J)* 7423 * RNNORM(K)*RNNORM(L) 7424 IF (ABS(QUANT).GE.THRTRM) THEN 7425 SUM_QUANT=SUM_QUANT+ABS(QUANT) 7426 WRITE (LMIDAS,'(1P,E23.16,4I6)') 7427 * QUANT,I, J, K, L 7428 NWRIT=NWRIT+1 7429 END IF 7430 240 CONTINUE 7431 END IF 7432C 7433C Count terms if permutation symmetry was not used 7434C 7435 NUNCON=0 7436 DO 250 L = 1, NDCOOR 7437 DO 260 K = 1, NDCOOR 7438 DO 270 J = 1, NDCOOR 7439 DO 280 I = 1, NDCOOR 7440 NUNCON=NUNCON+1 7441 280 ENDDO 7442 NUNCON=NUNCON+1 7443 270 ENDDO 7444 260 ENDDO 7445 NUNCON=NUNCON+1 7446 250 ENDDO 7447 WRITE (LUPRI,'(/,A,3(/,A,I8))') 7448 * " Force field has been written to Midas Operator File " , 7449 * " Number of terms without use of perm sym = " , NUNCON, 7450 * " Number of terms in total using pert sym = " , NTOT, 7451 * " Number of signficant terms written = " , NWRIT 7452 WRITE (LUPRI,'(A,E20.13,/,A)') 7453 * " Only terms with coefficients greater than " ,THRTRM , 7454 * " is written to operator file " 7455 WRITE (LUPRI,'(A,E20.13,/,A,/)') 7456 * " Sum of absolute values of coefficients: " ,SUM_QUANT, 7457 * " for the anharmonic part " 7458 END IF 7459C 7460C *** CLOSING FILE. *** 7461C 7462 CALL GPCLOSE(LMIDAS,'KEEP') 7463C 7464 RETURN 7465 END 7466C 7467C /* Deck rdc4hs */ 7468 SUBROUTINE RDC4HS(WORK,LWORK,IPRINT) 7469C ************************************************ 7470C *** Routine that reads hessian in the format *** 7471C *** written by the CFOUR program *** 7472C ************************************************ 7473#include "implicit.h" 7474#include "priunit.h" 7475#include "mxcent.h" 7476#include "nuclei.h" 7477#include "trkoor.h" 7478 LOGICAL HESEXS 7479 DIMENSION WORK(LWORK) 7480 7481 REAL*8 ERGMOL, GRDMOL(NCOOR), HESMOL(NCOOR,NCOOR) ! automatic arrays 7482 7483 INQUIRE (FILE='FCM',EXIST=HESEXS) 7484 7485 IF (.NOT. HESEXS ) CALL QUIT('Unable to open file FCM') 7486 7487 CALL ABAREAD_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 7488 7489 LUC4IF = -1 7490 7491C *** Open FCM file *** 7492 CALL GPOPEN(LUC4IF,'FCM','OLD',' ','FORMATTED',IDUMMY,.FALSE.) 7493 7494C *** Check that the written dimensions match this calculation *** 7495 READ(LUC4IF,*) IDIMEN 7496 IF (IDIMEN .NE. NUCDEP) CALL QUIT('Dimensions read in file '// 7497 & 'FCM does not match those in the molecule file' ) 7498 7499C *** We can now read the Hessian *** 7500 DO ICOOR1 = 1, NCOOR 7501 DO ICOOR2 = 1, NCOOR, 3 ! Three numbers at each line 7502 READ(LUC4IF,*,ERR=901) HESMOL( ICOOR2:ICOOR2+2,ICOOR1) 7503 END DO 7504 END DO 7505 7506 CALL GPCLOSE (LUC4IF,'KEEP') 7507 7508 CALL ABAWRIT_TAYMOL(ERGMOL,GRDMOL,HESMOL,NCOOR) 7509 7510 RETURN 7511 7512 901 CALL QUIT('An ERROR occured while reading file FCM') 7513 7514 END 7515C --- end of abander.F --- 7516