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 /* deck CC_SETFB12 */ 20*=====================================================================* 21 SUBROUTINE CC_SETFB12(IFTRAN,IFDOTS,MXTRAN,MXVEC, 22 & IZETAV,IOPER,IKAPPA,ITAMPA,ITAMPB, 23 & ITRAN,IVEC) 24*---------------------------------------------------------------------* 25* 26* Purpose: maintains a list of dot products of F{O} matrix 27* transformations with right amplitude vectors: 28* (Z*F{O}*T^A) * T^B 29* assumes that T^A and T^B belong to different lists 30* 31* IFTRAN - list of F matrix transformations 32* IFDOTS - list of vectors it should be dottet on 33* 34* MXTRAN - maximum list dimension 35* MXVEC - maximum second dimension for IFDOTS 36* 37* IZETAV - index of lagrangian multiplier vector 38* IOPER - index of property operator 39* IKAPPA - index of the relaxation vector 40* ITAMPA - index of amplitude vector A 41* ITAMPB - index of amplitude vector B 42* 43* ITRAN - index in IFTRAN list 44* IVEC - second index in IFDOTS list 45* 46* Written by Sonia Coriani, Maj 2000. Based on CC_SETFA and CC_SETFA12 47* 48*=====================================================================* 49 IMPLICIT NONE 50#include "priunit.h" 51 52 INTEGER MXVEC, MXTRAN 53 INTEGER IFTRAN(5,MXTRAN) 54 INTEGER IFDOTS(MXVEC,MXTRAN) 55 56 LOGICAL LFNDB 57 INTEGER IZETAV, IOPER, IKAPPA, ITAMPA, ITAMPB 58 INTEGER ITRAN, IVEC 59 INTEGER ITAMP, I, IDX 60 61* statement functions: 62 LOGICAL LFATST, LFAEND 63 INTEGER IL, IA, IO, IK 64 LFATST(ITRAN,IL,IO,IK,IA) = IFTRAN(1,ITRAN).EQ.IL 65 & .AND. IFTRAN(2,ITRAN).EQ.IO .AND. IFTRAN(3,ITRAN).EQ.IA 66 & .AND. IFTRAN(5,ITRAN).EQ.IK 67 LFAEND(ITRAN) = ITRAN.GT.MXTRAN .OR. 68 & (IFTRAN(1,ITRAN)+IFTRAN(2,ITRAN)+IFTRAN(3,ITRAN)).LE.0 69 70 71*---------------------------------------------------------------------* 72* set up list of F{B} matrix transformations 73*---------------------------------------------------------------------* 74 ITRAN = 1 75 LFNDB = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPA) 76 77 DO WHILE ( .NOT. (LFNDB.OR.LFAEND(ITRAN))) 78 ITRAN = ITRAN + 1 79 LFNDB = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPA) 80 END DO 81 82 IF (.NOT.LFNDB) THEN 83 IFTRAN(1,ITRAN) = IZETAV 84 IFTRAN(2,ITRAN) = IOPER 85 IFTRAN(3,ITRAN) = ITAMPA 86 IFTRAN(4,ITRAN) = 0 87 IFTRAN(5,ITRAN) = IKAPPA 88 ITAMP = ITAMPB 89 ELSE 90 IF (LFNDB) ITAMP = ITAMPB 91 END IF 92 93 IVEC = 1 94 DO WHILE (IFDOTS(IVEC,ITRAN).NE.ITAMP .AND. 95 & IFDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 96 IVEC = IVEC + 1 97 END DO 98 99 IFDOTS(IVEC,ITRAN) = ITAMP 100 101C WRITE (LUPRI,*) 'CC_SETFB12>',IZETAV,IOPER,ITAMPA,ITAMPB,ITRAN,IVEC 102*---------------------------------------------------------------------* 103 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 104 WRITE (LUPRI,*) 'IVEC :',IVEC 105 WRITE (LUPRI,*) 'ITRAN:',ITRAN 106 WRITE (LUPRI,*) 'IOPER,IKAPPA :',IOPER,IKAPPA 107 WRITE (LUPRI,*) 'ITAMPA,ITAMPB:',ITAMPA,ITAMPB 108 IDX = 1 109 DO WHILE ( .NOT. LFAEND(IDX) ) 110 WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') 'CC_SETFA12>', 111 & (IFTRAN(I,IDX),I=1,5),(IFDOTS(I,IDX),I=1,MXVEC) 112 IDX = IDX + 1 113 END DO 114 CALL FLSHFO(LUPRI) 115 CALL QUIT('Overflow error in CC_SETFA12.') 116 END IF 117 118 RETURN 119 END 120 121*---------------------------------------------------------------------* 122* END OF SUBROUTINE CC_SETFB12 * 123*---------------------------------------------------------------------* 124