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_setfa */ 20*=====================================================================* 21 SUBROUTINE CC_SETFA(IFTRAN,IFDOTS,MXTRAN,MXVEC,IZETAV, 22 & IOPER,IKAPPA,ITAMPA,ITAMPB,ITRAN,IVEC) 23*---------------------------------------------------------------------* 24* 25* Purpose: set up list of F matrix transformations 26* 27* IFTRAN - list of F matrix transformations 28* IFDOTS - list of vectors it should be dottet on 29* 30* MXTRAN - maximum list dimension 31* MXVEC - maximum second dimension for IFDOTS 32* 33* IZETAV - index of lagrangian multiplier vector 34* IOPER - index of property operator 35* IKAPPA - index of the relaxation vector 36* ITAMPA - index of amplitude vector A 37* ITAMPB - index of amplitude vector B 38* 39* ITRAN - index in IFTRAN list 40* IVEC - second index in IFDOTS list 41* 42* Written by Christof Haettig, november 1996. 43* IKAPPA entry added in june 1999 44* 45*=====================================================================* 46 IMPLICIT NONE 47#include "priunit.h" 48 49 INTEGER MXVEC, MXTRAN 50 INTEGER IFTRAN(5,MXTRAN) 51 INTEGER IFDOTS(MXVEC,MXTRAN) 52 53 LOGICAL LFNDA, LFNDB 54 INTEGER IZETAV, IOPER, IKAPPA, ITAMPA, ITAMPB 55 INTEGER ITRAN, IVEC 56 INTEGER ITAMP, I, IDX 57 58* statement functions: 59 LOGICAL LFATST, LFAEND 60 INTEGER IL, IA, IO, IK 61 LFATST(ITRAN,IL,IO,IK,IA) = 62 & IFTRAN(1,ITRAN).EQ.IL .AND. IFTRAN(2,ITRAN).EQ.IO 63 & .AND. IFTRAN(3,ITRAN).EQ.IA .AND. IFTRAN(5,ITRAN).EQ.IK 64 LFAEND(ITRAN) = ITRAN.GT.MXTRAN .OR. 65 & (IFTRAN(1,ITRAN)+IFTRAN(2,ITRAN)+IFTRAN(3,ITRAN)).LE.0 66 67 68*---------------------------------------------------------------------* 69* set up list of F{A} matrix transformations 70*---------------------------------------------------------------------* 71 ITRAN = 1 72 LFNDA = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPB) 73 LFNDB = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPA) 74 75 DO WHILE ( .NOT. (LFNDA.OR.LFNDB.OR.LFAEND(ITRAN))) 76 ITRAN = ITRAN + 1 77 LFNDA = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPB) 78 LFNDB = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPA) 79 END DO 80 81 IF (.NOT.(LFNDA.OR.LFNDB)) THEN 82 IFTRAN(1,ITRAN) = IZETAV 83 IFTRAN(2,ITRAN) = IOPER 84 IFTRAN(3,ITRAN) = ITAMPA 85 IFTRAN(4,ITRAN) = 0 86 IFTRAN(5,ITRAN) = IKAPPA 87 ITAMP = ITAMPB 88 ELSE 89 IF (LFNDA) ITAMP = ITAMPA 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 101*---------------------------------------------------------------------* 102 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 103 WRITE (LUPRI,*) 'Overflow error in CC_SETFA:' 104 WRITE (LUPRI,*) 'IVEC, MXVEC :',IVEC, MXVEC 105 WRITE (LUPRI,*) 'ITRAN, MXTRAN:',ITRAN, MXTRAN 106 WRITE (LUPRI,*) 'IOPER,IKAPPA :',IOPER,IKAPPA 107 WRITE (LUPRI,*) 'IZETAV,ITAMPA,ITAMPB:',IZETAV,ITAMPA,ITAMPB 108 IDX = 1 109 DO WHILE ( .NOT. LFAEND(IDX) ) 110 WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') 'CC_SETFA>', 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_SETFA') 116 END IF 117 118 RETURN 119 END 120 121*---------------------------------------------------------------------* 122* END OF SUBROUTINE CC_SETFA * 123*---------------------------------------------------------------------* 124