1*=====================================================================* 2 SUBROUTINE CC_SETK11(IKTRAN,IKDOTS,MXTRAN,MXVEC, 3 & IZETVA,IZETVB,ITAMPC,ITRAN,IVEC) 4*---------------------------------------------------------------------* 5* 6* Purpose: set up list of K matrix transformations 7* assumes that bar{T^A} and bar{T^B} members of the same list 8* 9* IKTRAN - list of K matrix transformations 10* IKDOTS - list of vectors it should be dottet on 11* 12* MXTRAN - maximum list dimension 13* MXVEC - maximum second dimension for IBDOTS 14* 15* IZETVA - index of lagrangian multiplier vector A 16* IZETVB - index of lagrangian multiplier vector B 17* ITAMPC - index of amplitude vector C 18* 19* ITRAN - index in IKTRAN list 20* IVEC - second index in IKDOTS list 21* 22* CCMM JK+OC, modified version of CC_SETB11 23* 24*=====================================================================* 25 IMPLICIT NONE 26 27#include "priunit.h" 28 INTEGER MXVEC, MXTRAN 29 INTEGER IKTRAN(3,MXTRAN) 30 INTEGER IKDOTS(MXVEC,MXTRAN) 31 32 LOGICAL LFND 33 INTEGER IZETVA, IZETVB, ITAMPC 34 INTEGER ITRAN, IVEC 35 INTEGER IZETV, I, IDX 36 37* statement functions: 38 LOGICAL LBTST, LBEND 39 INTEGER IB, IA 40 LBTST(ITRAN,IA,IB) = 41 & ( IKTRAN(1,ITRAN).EQ.IA .AND. IKTRAN(2,ITRAN).EQ.IB ) .OR. 42 & ( IKTRAN(1,ITRAN).EQ.IB .AND. IKTRAN(2,ITRAN).EQ.IA ) 43 LBEND(ITRAN) = ITRAN.GT.MXTRAN .OR. 44 & (IKTRAN(1,ITRAN)+IKTRAN(2,ITRAN)).LE.0 45 46*---------------------------------------------------------------------* 47* set up list of K matrix transformations 48*---------------------------------------------------------------------* 49 ITRAN = 1 50 LFND = LBTST(ITRAN,IZETVA,IZETVB) 51 52 DO WHILE ( .NOT. (LFND.OR.LBEND(ITRAN)) ) 53 ITRAN = ITRAN + 1 54 LFND = LBTST(ITRAN,IZETVA,IZETVB) 55 END DO 56 57 IF (.NOT.LFND) THEN 58 IKTRAN(1,ITRAN) = IZETVA 59 IKTRAN(2,ITRAN) = IZETVB 60 IKTRAN(3,ITRAN) = 0 61 IZETV = ITAMPC 62 ELSE 63 IF (LFND) IZETV = ITAMPC 64 END IF 65 66 IVEC = 1 67 DO WHILE (IKDOTS(IVEC,ITRAN).NE.IZETV .AND. 68 & IKDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 69 IVEC = IVEC + 1 70 END DO 71 72 IKDOTS(IVEC,ITRAN) = IZETV 73 74*---------------------------------------------------------------------* 75 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 76 WRITE (LUPRI,*) 'IVEC :',IVEC 77 WRITE (LUPRI,*) 'ITRAN:',ITRAN 78 WRITE (LUPRI,*) 'IZETVA,IZETVB:',IZETVA,IZETVB 79 IDX = 1 80 DO WHILE ( .NOT. LBEND(IDX) ) 81 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') 'CC_SETK11>', 82 & (IKTRAN(I,IDX),I=1,3),(IKDOTS(I,IDX),I=1,MXVEC) 83 IDX = IDX + 1 84 END DO 85 CALL FLSHFO(LUPRI) 86 CALL QUIT('Overflow error in CC_SETK11.') 87 END IF 88 89 RETURN 90 END 91 92 93