Merge branch 'compas/master'

Author: mortenpi

grasptest/example4/script/clean

@@ -19,6 +19,6 @@ rm energylabel*
 rm *.pdf
 rm *.tex
 rm *.aux
-cd ../tmp_mpi
+cd ./tmp_mpi
 rm */*
 cd ..

src/appl/rmcdhf90/in.f90

@@ -72,7 +72,6 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP)
 !
 !   Global initializations
 !
-!ww      EPS = 0.1D 00*ACCY
       EPS = 0.01D00*ACCY
       HHK = 0.5D00*H*DBLE(NAK(IORB))
 !
@@ -143,7 +142,7 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP)
 !
       TLAST = TTHIS
       TTHIS = ABS(XS(I)/TI(I))
-      IF (TTHIS + TLAST <= EPS) THEN
+      IF (TTHIS + TLAST <= EPS .OR. J .EQ. NNNP-1 ) THEN 
          MTP = J
       ELSE
          GO TO 1

src/appl/rmcdhf90/setlag.f90

@@ -56,11 +56,11 @@ SUBROUTINE SETLAG(EOL)
 !-----------------------------------------------
 !   L o c a l   V a r i a b l e s
 !-----------------------------------------------
-      INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLI, LJRAW, LJ, IECCLI, L1, L2, &
+      INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLJ, LJRAW, LJ, IECCLI, L1, L2, &
          JLAST, MLAST, M, J, I
       REAL(DOUBLE), DIMENSION(NNNP) :: YPJ, YPM, XPJ, XPM, XQJ, XQM
       REAL(DOUBLE) :: EPS, UCFJ, UCFM, RESULT, RIJM, QDIF, OBQDIF, OBQSUM
-      LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ
+      LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ, VLI, VLJ
 !-----------------------------------------------
 !
       DATA FIRST/ .TRUE./
@@ -85,65 +85,28 @@ SUBROUTINE SETLAG(EOL)
          EPS = ACCY*0.01D0      ! criterion to see if an orb is occupied
          DO ITWICE = 1, 2
             NEC = 0
-!            IF (ITWICE /= 2) THEN
-!               DO LIRAW = 1, NW - 1
-!                  LI = IORDER(LIRAW)
-!                  LIP1 = MAX(NCORE,LIRAW) + 1
-!                  NAKLI = NAK(LI)
-!                  FIXLI = LFIX(LI)
-!                  FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS
-!                  DO LJRAW = LIP1, NW
-!                     LJ = IORDER(LJRAW)
-!                     FIXLJ = LFIX(LJ)
-!                     FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS
-!                     IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)&
-!                         .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE
-!                     NEC = NEC + 1
-!                     CYCLE
-!                  !*** Encode index at 2nd round ***
-!                  END DO
-!               END DO
-!            ELSE
-!               DO LIRAW = 1, NW - 1
-!                  LI = IORDER(LIRAW)
-!                  LIP1 = MAX(NCORE,LIRAW) + 1
-!                  NAKLI = NAK(LI)
-!                  FIXLI = LFIX(LI)
-!                  FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS
-!                  !*** Encode index at 2nd round ***
-!                  DO LJRAW = LIP1, NW
-!                     LJ = IORDER(LJRAW)
-!                     FIXLJ = LFIX(LJ)
-!                     FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS
-!                     IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)&
-!                         .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE
-!                     NEC = NEC + 1
-!                  !*** Encode index at 2nd round ***
-!                     IECC(NEC) = LI + KEY*LJ
-!                  END DO
-!               END DO
-!            ENDIF
-         DO LIraw = 1, NW - 1
-            LI = iorder(LIraw)
-            LIP1 = MAX (NCORE, LIraw) + 1
-            NAKLI = NAK(LI)
-            FIXLI = LFIX(LI)
-            FULLI = ABS ( UCF(LI)-DBLE (NKJ(LI)+1) ) .LT. EPS
-            DO LJraw = LIP1, NW
+         DO LJraw = NCORE+1, NW
                LJ = iorder(LJraw)
-               FIXLJ = LFIX(LJ)
+            NAKLJ = NAK(LJ)
+            VLJ = .NOT. LFIX(LJ)
                FULLJ = ABS ( UCF(LJ)-DBLE (NKJ(LJ)+1) ) .LT. EPS
-               IF ( (NAK(LJ) .EQ. NAKLI) .AND.            &
-                     (.NOT. (FIXLI .AND. FIXLJ)) .AND.    &
-                     (.NOT. (FULLI .AND. FULLJ)) ) THEN
+            DO LIraw = 1, LJraw-1
+               LI = iorder(LIraw)
+               VLI = .NOT. LFIX(LI)
+               FULLI = ABS ( UCF(LI)-DBLE (NKJ(LI)+1) ) .LT. EPS
+               IF  (NAK(LI) .EQ. NAKLJ) then
+                  If  (VLI  .OR. VLJ ) then       ! at least one orbital varied
+!                                                   but not both (varied and full)
+                     If (.NOT. ((VLI .AND. VLJ) .AND. (FULLI .AND. FULLJ))) THEN 
                   NEC = NEC + 1
                   !*** Encode index at 2nd round ***
                   IF (itwice == 2) IECC(NEC) = LI + KEY * LJ
                ENDIF
+                  ENDIF
+               ENDIF
             ENDDO
          ENDDO
 
-
             IF (ITWICE==1 .AND. NEC>0) THEN
                CALL ALLOC (ECV, NEC, 'ECV', 'SETLAG')
                CALL ALLOC (IECC, NEC, 'IECC', 'SETLAG')
@@ -173,7 +136,6 @@ SUBROUTINE SETLAG(EOL)
          FIRST = .FALSE.
       ENDIF
 
-!FF+GG  12/07/05
 !     Lagrange multipliers need to be computed also on the first call
 !     RETURN
 
@@ -217,11 +179,12 @@ SUBROUTINE SETLAG(EOL)
          IF (LFIX(M)) THEN
             TA(1) = 0.D0
             DO I = 2, MTP
-               TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+(PF(I,M)*PF(I&
-                  ,J)+QF(I,M)*QF(I,J))*YPJ(I))
+               TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+       &
+                                (PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J))*YPJ(I)) 
             END DO
 
             CALL QUAD (RESULT)
+! note      ..rinti(m,j,1) is symmetric in (j,m)
             RIJM = RINTI(M,J,1)
             ECV(LI) = (RESULT - RIJM)*UCFJ
 
@@ -236,8 +199,8 @@ SUBROUTINE SETLAG(EOL)
          ELSE IF (LFIX(J)) THEN
             TA(1) = 0.D0
             DO I = 2, MTP
-               TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+(PF(I,J)*PF(I&
-                  ,M)+QF(I,J)*QF(I,M))*YPM(I))
+               TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+      &
+                                (PF(I,J)*PF(I,M)+QF(I,J)*QF(I,M))*YPM(I)) 
             END DO
 
 !start dbg
@@ -258,20 +221,22 @@ SUBROUTINE SETLAG(EOL)
 !           WRITE (81,*)RESULT, RIJM, UCFJ, ECV, r(i), rp(i)
 !end dbg
 
-
          ELSE
+            
             QDIF = ABS((UCFJ - UCFM)/MAX(UCFJ,UCFM))
+            
             IF (QDIF > P001) THEN
                OBQDIF = 1.D0/UCFJ - 1.D0/UCFM
                TA(1) = 0.D0
                DO I = 2, MTP
-                  TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)-PF(I,J)*XQM(I&
-                     )+QF(I,J)*XPM(I))*C+(YPJ(I)-YPM(I))*(PF(I,M)*PF(I,J)+QF(I,&
-                     M)*QF(I,J)))
+                  TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)          &
+                                   -PF(I,J)*XQM(I)+QF(I,J)*XPM(I))*C       &
+                          +(YPJ(I)-YPM(I))*(PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J))) 
                END DO
 
                CALL QUAD (RESULT)
                ECV(LI) = RESULT/OBQDIF
+
 !start dbg
 !           WRITE (81,*)'3, RESULT, OBQDIF, ECV, TA'
 !           WRITE (81,*)RESULT, OBQDIF, ECV
@@ -280,19 +245,22 @@ SUBROUTINE SETLAG(EOL)
 !           ENDDO
 !end dbg
 
-
             ELSE
+ 
                OBQSUM = 1.D0/UCFJ + 1.D0/UCFM
+
                TA(1) = 0.D0
                DO I = 2, MTP
-                  TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)+PF(I,J)*XQM(I&
-                     )-QF(I,J)*XPM(I))*C+(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,&
-                     M)*QF(I,J)))
+                  TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)         &
+                                   +PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C      &
+                         +(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J))) 
                END DO
 
                CALL QUAD (RESULT)
-               RIJM = RINTI(M,J,1)               !/ nprocs
-               ECV(LI) = (RESULT - 2.D0*RIJM)/OBQSUM
+               RIJM = RINTI(M,J,1)               
+               ECV(LI) = (RESULT - 2.0*RIJM)/OBQSUM 
+
+
 !start dbg
 !           WRITE (81,*)'4, RESULT, RIUJM, OBQSUM, ECV, TA'
 !           WRITE (81,*)RESULT, RIUJM, OBQSUM, ECV
@@ -308,10 +276,6 @@ SUBROUTINE SETLAG(EOL)
 
       END DO
 
-!db      close(81)
-!db      close(82)
-
-
   302 FORMAT(/,'Lagrange multipliers are not required')
   304 FORMAT(/,'Include Lagrange multipliers between:'/)
   305 FORMAT(13X,2(2X,1I2,1A2))

src/appl/rmcdhf90_mpi/in.f90

@@ -143,7 +143,8 @@ SUBROUTINE IN(IORB, JP, P, Q, MTP)
 !
       TLAST = TTHIS
       TTHIS = ABS(XS(I)/TI(I))
-      IF (TTHIS + TLAST <= EPS) THEN
+!cff  Stop if J=NNNP
+      IF (TTHIS + TLAST <= EPS .OR. J .EQ. NNNP-1 ) THEN 
          MTP = J
       ELSE
          GO TO 1

src/appl/rmcdhf90_mpi/setlagmpi.f90

@@ -56,11 +56,11 @@ SUBROUTINE SETLAGmpi(EOL)
 !-----------------------------------------------
 !   L o c a l   V a r i a b l e s
 !-----------------------------------------------
-      INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLI, LJRAW, LJ, IECCLI, L1, L2, &
+      INTEGER :: ITWICE, LIRAW, LI, LIP1, NAKLJ, LJRAW, LJ, IECCLI, L1, L2, &
          JLAST, MLAST, M, J, I
       REAL(DOUBLE), DIMENSION(NNNP) :: YPJ, YPM, XPJ, XPM, XQJ, XQM
       REAL(DOUBLE) :: EPS,UCFJ,UCFM,RESULT,RIJM,QDIF,OBQDIF,OBQSUM,TMP
-      LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ
+      LOGICAL :: FIRST, FIXLI, FIXLJ, FULLI, FULLJ, VLI, VLJ
 !-----------------------------------------------
 !
       DATA FIRST/ .TRUE./
@@ -85,61 +85,25 @@ SUBROUTINE SETLAGmpi(EOL)
          EPS = ACCY*0.01D0      ! criterion to see if an orb is occupied
          DO ITWICE = 1, 2
             NEC = 0
-!            IF (ITWICE /= 2) THEN
-!               DO LIRAW = 1, NW - 1
-!                  LI = IORDER(LIRAW)
-!                  LIP1 = MAX(NCORE,LIRAW) + 1
-!                  NAKLI = NAK(LI)
-!                  FIXLI = LFIX(LI)
-!                  FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS
-!                  DO LJRAW = LIP1, NW
-!                     LJ = IORDER(LJRAW)
-!                     FIXLJ = LFIX(LJ)
-!                     FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS
-!                     IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)&
-!                         .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE
-!                     NEC = NEC + 1
-!                     CYCLE
-!                  !*** Encode index at 2nd round ***
-!                  END DO
-!               END DO
-!            ELSE
-!               DO LIRAW = 1, NW - 1
-!                  LI = IORDER(LIRAW)
-!                  LIP1 = MAX(NCORE,LIRAW) + 1
-!                  NAKLI = NAK(LI)
-!                  FIXLI = LFIX(LI)
-!                  FULLI = ABS(UCF(LI)-DBLE(NKJ(LI)+1)) < EPS
-!                  !*** Encode index at 2nd round ***
-!                  DO LJRAW = LIP1, NW
-!                     LJ = IORDER(LJRAW)
-!                     FIXLJ = LFIX(LJ)
-!                     FULLJ = ABS(UCF(LJ)-DBLE(NKJ(LJ)+1)) < EPS
-!                     IF (.NOT.(NAK(LJ)==NAKLI .AND. .NOT.(FIXLI .AND. FIXLJ)&
-!                         .AND. .NOT.(FULLI .AND. FULLJ))) CYCLE
-!                     NEC = NEC + 1
-!                  !*** Encode index at 2nd round ***
-!                     IECC(NEC) = LI + KEY*LJ
-!                  END DO
-!               END DO
-!            ENDIF
-         DO LIraw = 1, NW - 1
-            LI = iorder(LIraw)
-            LIP1 = MAX (NCORE, LIraw) + 1
-            NAKLI = NAK(LI)
-            FIXLI = LFIX(LI)
-            FULLI = ABS ( UCF(LI)-DBLE (NKJ(LI)+1) ) .LT. EPS
-            DO LJraw = LIP1, NW
+         DO LJraw = NCORE+1, NW
                LJ = iorder(LJraw)
-               FIXLJ = LFIX(LJ)
+            NAKLJ = NAK(LJ)
+            VLJ = .NOT. LFIX(LJ)
                FULLJ = ABS ( UCF(LJ)-DBLE (NKJ(LJ)+1) ) .LT. EPS
-               IF ( (NAK(LJ) .EQ. NAKLI) .AND.            &
-                     (.NOT. (FIXLI .AND. FIXLJ)) .AND.    &
-                     (.NOT. (FULLI .AND. FULLJ)) ) THEN
+            DO LIraw = 1, LJraw-1
+               LI = iorder(LIraw)
+               VLI = .NOT. LFIX(LI)
+               FULLI = ABS ( UCF(LI)-DBLE (NKJ(LI)+1) ) .LT. EPS
+               IF  (NAK(LI) .EQ. NAKLJ) then
+                  If  (VLI  .OR. VLJ ) then          !at least one varid
+!                                                    ! but not (both varied and full)
+                     If (.NOT. ((VLI .AND. VLJ) .AND. (FULLI .AND. FULLJ))) THEN 
                   NEC = NEC + 1
                   !*** Encode index at 2nd round ***
                   IF (itwice == 2) IECC(NEC) = LI + KEY * LJ
                ENDIF
+                  ENDIF
+               ENDIF
             ENDDO
          ENDDO
 
@@ -217,8 +181,8 @@ SUBROUTINE SETLAGmpi(EOL)
          IF (LFIX(M)) THEN
             TA(1) = 0.D0
             DO I = 2, MTP
-               TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+(PF(I,M)*PF(I&
-                  ,J)+QF(I,M)*QF(I,J))*YPJ(I))
+               TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I))*C+       &
+                                (PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J))*YPJ(I))
             END DO
 
             CALL QUAD (RESULT)
@@ -235,9 +199,8 @@ SUBROUTINE SETLAGmpi(EOL)
          ELSE IF (LFIX(J)) THEN
             TA(1) = 0.D0
             DO I = 2, MTP
-               TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+(PF(I,J)*PF(I&
-                  ,M)+QF(I,J)*QF(I,M))*YPM(I))
-!GG             write(222,*)"XQM(I)",XQM(I)
+               TA(I) = RPOR(I)*((PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C+      &
+                                (PF(I,J)*PF(I,M)+QF(I,J)*QF(I,M))*YPM(I))
             END DO
 
 !start dbg
@@ -260,34 +223,12 @@ SUBROUTINE SETLAGmpi(EOL)
 
 
          ELSE
-            QDIF = ABS((UCFJ - UCFM)/MAX(UCFJ,UCFM))
-            IF (QDIF > P001) THEN
-               OBQDIF = 1.D0/UCFJ - 1.D0/UCFM
-               TA(1) = 0.D0
-               DO I = 2, MTP
-                  TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)-PF(I,J)*XQM(I&
-                     )+QF(I,J)*XPM(I))*C+(YPJ(I)-YPM(I))*(PF(I,M)*PF(I,J)+QF(I,&
-                     M)*QF(I,J)))
-               END DO
-
-               CALL QUAD (RESULT)
-               ECV(LI) = RESULT/OBQDIF
-!start dbg
-!           WRITE (81,*)'3, RESULT, OBQDIF, ECV, TA'
-!           WRITE (81,*)RESULT, OBQDIF, ECV
-!           DO i = 1, MTP
-!              WRITE (81,*) i, TA(i), r(i), rp(i)
-!           ENDDO
-!end dbg
-
-
-            ELSE
                OBQSUM = 1.D0/UCFJ + 1.D0/UCFM
                TA(1) = 0.D0
                DO I = 2, MTP
-                  TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)+PF(I,J)*XQM(I&
-                     )-QF(I,J)*XPM(I))*C+(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,&
-                     M)*QF(I,J)))
+                  TA(I) = RPOR(I)*((PF(I,M)*XQJ(I)-QF(I,M)*XPJ(I)         &
+                                   +PF(I,J)*XQM(I)-QF(I,J)*XPM(I))*C      &
+                         +(YPJ(I)+YPM(I))*(PF(I,M)*PF(I,J)+QF(I,M)*QF(I,J)))
                END DO
 
                CALL QUAD (RESULT)
@@ -301,7 +242,7 @@ SUBROUTINE SETLAGmpi(EOL)
 !           ENDDO
 !end dbg
 
-            ENDIF
+!           ENDIF 
          ENDIF
 !=======================================================================
 !  Collect contributions from all nodes.

src/appl/rtransition90/ldlbl1.f90

@@ -59,7 +59,7 @@ SUBROUTINE LDLBL1 (NAME)
 !
             READ (31,'(7X,F12.8,17X,A)') WEIGHTS,string_CSF1(ICount)
 !
-    2       READ (31,'(1X,I2)',IOSTAT = IOS),ITEST
+    2       READ (31,'(1X,I2)',IOSTAT = IOS) ITEST
             IF (IOS .NE. 0) GO TO 1
             IF (ITEST .EQ. 0) GO TO 2
             BACKSPACE 31