C FORTRAN PROGRAM gesol_external_out_f
C WRITTEN BY ALEK MARENICH (AVM) ON 07/24/2008
C LAST TIME MODIFIED BY ALEK MARENICH (AVM) ON 02/27/2009
C
C THIS PROGRAM CALLED BY gesol_external
C 1) RETRIEVES ENERGY, GRADIENT, HESSIAN DATA FROM 
C    FILE g03_external.fchk AFTER EXTERNAL GAUSSIAN CALCULATION 
C    CALLED BY gesol_external
C 2) RETRIEVES CDS CONTRIBUTIONS CALCULATED BY gesol_external_inp_f
C  
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (MAT=250,MF=(3*MAT*3*MAT+3*MAT)/2)
      DIMENSION G(3*MAT),F(MF),POL(6),DDIP(9*MAT)

      DIMENSION DCDS(3*MAT),CDSA(MAT),NUC(MAT),
     $FCDS(MF),RAD(MAT),RADVDW(MAT),ATAREA(MAT),
     $CART(3*MAT)

      CHARACTER*30 T30
      CHARACTER*70 W70
      LOGICAL LEXIST
      
      AUTOKCAL=627.5131018D0
      SMALL=1.0D-08
    
C CHECKING ENERGIES FROM g03_external.log AND LEAVING
      LEXIST=.FALSE.
      INQUIRE (FILE='wrkegasout',EXIST=LEXIST)
      IF (LEXIST) THEN
      OPEN (1,FILE='wrkegasout')
      E1=-9999
      E2=9999
      READ (1,*,ERR=2,END=2) E1,E2
2     CONTINUE
      CLOSE (1,STATUS='DELETE')
      IF (DABS(E1-E2).LE.SMALL*200) THEN  
      OPEN (1,FILE='g03_externalgas.com')
      CLOSE (1,STATUS='DELETE')
      ENDIF
      STOP
      ENDIF
     

      OPEN (2,FILE='gesol_output')
      OPEN (4,FILE='wrkerr')
      WRITE (4,'(/,A)') ' Abnormal termination!'
      WRITE (2,*)

      ICALC=1
      LEXIST=.FALSE.
      INQUIRE (FILE='wrkcalc',EXIST=LEXIST)
      IF (LEXIST) THEN
      OPEN (1,FILE='wrkcalc')
      READ (1,*) ICALC
      CLOSE (1,STATUS='DELETE')
      ENDIF
      OPEN (1,FILE='wrkcalc')
      WRITE (1,*) ICALC+1
      CLOSE (1)


C RETRIEVAL OF ENERGY, GRADIENT, HESSIAN DATA FROM GAUSSIAN OUTPUT

      OPEN (1,FILE='shuttle.inp')
      READ (1,*) W70
      CLOSE (1,STATUS='DELETE')

   
      OPEN (1,FILE=W70)
      READ (1,*) NAT, METH, ICH, MUL
      DO I=1,NAT
      READ (1,*)  NUC(I)
      ENDDO
      CLOSE (1)

      OPEN (1,FILE='shuttle.out')
      READ (1,*) E, W70
      CLOSE (1,STATUS='DELETE')

      OPEN (1,FILE='wrk')
      READ (1,*) 
     $IPCM,ISOL,ICDS,DIELEC,SOLN,
     $SOLA,SOLB,SOLG,SOLC,SOLH
      CLOSE (1)

      DO I=1,MAT*3
      G(I)=0.D0
      ENDDO
      DO I=1,MF
      F(I)=0.D0
      ENDDO
      DO I=1,6
      POL(I)=0.D0
      ENDDO
      DO I=1,9*MAT
      DDIP(I)=0.D0
      ENDDO
      DPX=0.D0
      DPY=0.D0
      DPZ=0.D0

      NF=(3*NAT+3*NAT*3*NAT)/2

      OPEN (1,FILE='g03_external.fchk')

10    CONTINUE
      READ (1,'(A)',END=11,ERR=11) T30
      CALL CAPS(T30)
      IF (T30.NE.'CARTESIANGRADIENT') GOTO 10
      READ (1,*) (G(I),I=1,3*NAT)
11    CONTINUE
      REWIND (1)
20    CONTINUE
      READ (1,'(A)',END=21,ERR=21) T30
      CALL CAPS(T30)
      IF (T30.NE.'CARTESIANFORCECONSTANTS') GOTO 20
      READ (1,*) (F(I),I=1, NF)
21    CONTINUE
      REWIND (1)
30    CONTINUE
      READ (1,'(A)',END=31,ERR=31) T30
      CALL CAPS(T30)
      IF (T30.NE.'DIPOLEMOMENT') GOTO 30
      READ (1,*) DPX,DPY,DPZ
31    CONTINUE
      REWIND (1)
40    CONTINUE
      READ (1,'(A)',END=41,ERR=41) T30
      CALL CAPS(T30)
      IF (T30.NE.'POLARIZABILITY') GOTO 40
      READ (1,*) (POL(I),I=1,6)
41    CONTINUE
      REWIND (1)
50    CONTINUE
      READ (1,'(A)',END=51,ERR=51) T30
      CALL CAPS(T30)
      IF (T30.NE.'DIPOLEDERIVATIVES') GOTO 50
      READ (1,*) (DDIP(I),I=1,NAT*9)
51    CONTINUE

      CLOSE (1)

      EGAS=9999.D0
      GEN=9999.D0
      GENP=E
      IF (IPCM.GT.0) THEN
      OPEN (1,FILE='wrksolv')
      READ (1,*,ERR=65,END=65) EGAS,GEN,GENP
      ENDIF
      GOTO 68
65    CONTINUE
      WRITE (2,'(A,A)') ' ERROR IN gesol_external_out_f:',
     $' INCOMPLETE DATA IN GAUSSIAN OUTPUT! STOP.'
      WRITE (2,*)
      STOP
68    CONTINUE
      CLOSE (1)

      IF (DABS(GENP-E).GE.0.000016D0) THEN
      GEN=9999.D0
      GENP=E
      ENDIF


C END OF RETRIEVAL OF ENERGY, GRADIENT, HESSIAN DATA FROM GAUSSIAN OUTPUT


C RETRIEVAL OF CDS CONTRIBUTIONS CALCULATED BY gesol_external_inp_f

      CDST=0.D0
      TAREA=0.D0 
      DO I=1,NAT
      CDSA(I)=0.D0
      ENDDO
      DO I=1,3*NAT
      DCDS(I)=0.D0
      ENDDO
      DO I=1,NF
      FCDS(I)=0.D0
      ENDDO

      CDST=0.D0

      IF (ICDS.EQ.1) THEN

      OPEN (1,FILE='wrkecds') 
      READ (1,*,ERR=75,END=75) CDST,TAREA 
      READ (1,*,ERR=75,END=75) (CDSA(I),I=1,NAT)
      READ (1,*,ERR=75,END=75) (RADVDW(I),I=1,NAT)
      READ (1,*,ERR=75,END=75) (ATAREA(I),I=1,NAT)
      CLOSE (1)

      OPEN (1,FILE='wrkgcds') 
      READ (1,*,ERR=80,END=80) (CART(I),I=1,3*NAT)
      READ (1,*,ERR=80,END=80) (DCDS(I),I=1,3*NAT) 
      CLOSE (1)

       IF (METH.EQ.2) THEN
       OPEN (1,FILE='wrkfcds') 
        DO I=1,NF
        READ (1,*,ERR=85,END=85) I1,I2,I3,I4,FCDS(I)
        ENDDO 
       CLOSE (1)
       ENDIF

      ENDIF

C END OF RETRIEVAL OF CDS CONTRIBUTIONS CALCULATED BY gesol_external_inp_f


C WRITING A SUMMARY OF SOLVATION CALCULATION

      WRITE(2,'(/," ***************************************",        
     .               "****************************************")')      
      WRITE(2,'(20X,A,I4)')
     $'GESOL SUMMARY FOR STEP #',ICALC       
      WRITE(2,'(" ***************************************",        
     .  "****************************************",/)')

      IF (IPCM.EQ.0) THEN
      WRITE (2,'(A,/)') ' NO SOLVATION CALCULATION WAS PERFORMED'
                     ELSE

      WRITE(2,'(/,3X,A,/,3X,A,F6.2)')
     $'SOLVATION FREE ENERGY CONTRIBUTIONS AT 298.15 K',
     $'FOR SOLVENT WITH DIELECTRIC CONSTANT ',DIELEC       
      WRITE(2,'(" ---------------------------------------",        
     .  "----------------------------------------")')

      IF (GEN.GT.9998.D0) THEN
      WRITE (2,'(A,T54,F18.6,A)')
     $' (0) E-EN(g) gas-phase elect-nuc energy',EGAS,' a.u.'
      WRITE (2,'(A,T54,F18.6,A)') 
     $' (1) G-ENP(liq) elect-nuc-pol free energy of system',
     $GENP,' a.u.'
      WRITE (2,'(A,/,A,T54,F18.3,A)') 
     $' (2) G-CDS(liq) cavity-dispersion-solvent structure',
     $'     free energy',CDST,' kcal/mol'
      WRITE (2,100) GENP+CDST/AUTOKCAL
      WRITE (2,99) (GENP+CDST/AUTOKCAL-EGAS)*AUTOKCAL
100   FORMAT (' (3) G-S(liq) free energy of system = (1) + (2)',
     .        T54,F18.6,' a.u.')
99    FORMAT (' (4) DeltaG-S(liq) free energy of solvation',/,
     .        '     (4) = (3) - (0)',T54,F18.3,' kcal/mol')
       ELSE

      WRITE (2,101) EGAS
101   FORMAT (' (0) E-EN(g) gas-phase elect-nuc energy',
     .        T54,F18.6,    ' a.u.')
      WRITE (2,102) GEN
102   FORMAT (' (1) E-EN(liq) elect-nuc energy of solute',
     .        T54,F18.6,    ' a.u.')
      WRITE (2,103) (GENP-GEN)*AUTOKCAL
103   FORMAT (' (2) G-P(liq) polarization free energy of',
     .        ' solvation',T54,F18.3,' kcal/mol')
      WRITE (2,104) GENP
104   FORMAT (' (3) G-ENP(liq) elect-nuc-pol free energy of system',
     .        T54,F18.6,    ' a.u.')
      WRITE (2,105) CDST
105   FORMAT (' (4) G-CDS(liq) cavity-dispersion-solvent structure'
     .     ,/,'     free energy',T54,F18.3,' kcal/mol')
      WRITE (2,106) (GENP-GEN)*AUTOKCAL+CDST
106   FORMAT (' (5) G-P-CDS(liq) = G-P(liq) + G-CDS(liq) = (2) + (4)',
     .        T54,F18.3,' kcal/mol')
      WRITE (2,107) GENP+CDST/AUTOKCAL
107   FORMAT (' (6) G-S(liq) free energy of system = (1) + (5)',
     .        T54,F18.6,    ' a.u.')
      WRITE (2,108) (GEN-EGAS)*AUTOKCAL
108   FORMAT (' (7) DeltaE-EN(liq) elect-nuc reorganization',/,
     .        '     energy of solute molecule (7) = (1) - (0)',
     .        T54,F18.3,' kcal/mol')
      WRITE (2,109) (GENP-EGAS)*AUTOKCAL
109   FORMAT (' (8) DeltaG-ENP(liq) elect-nuc-pol free energy',/,
     .        '     of solvation (8) = (3) - (0)',
     .        T54,F18.3,' kcal/mol')
      WRITE (2,110) (GENP-EGAS)*AUTOKCAL+CDST
110   FORMAT (' (9) DeltaG-S(liq) free energy of solvation',/,
     .        '     (9) = (6) - (0)',T54,F18.3,' kcal/mol') 
      ENDIF    
      WRITE (2,'(" ---------------------------------------",          
     .             "----------------------------------------",/)')

      OPEN (1,FILE='wrkrad')
      READ (1,*) (RAD(I),I=1,NAT)
      CLOSE (1)

      WRITE (2,'(2(/,3X,A))') 
     $'COULOMB RADII FOR',
     $'BULK ELECTROSTATICS'
      WRITE (2,'(A)') ' ---------------------------------'
      WRITE (2,'(X,A,5X,A,3X,A)')
     .         'Center','Atomic','Radius'
      WRITE (2,'(X,A,5X,A,3X,A)')
     .         'Number','Number',' Angs'
      WRITE (2,'(A)') ' ---------------------------------'
      DO I=1, NAT
      WRITE (2,'(2X,I2,9X,I2,5X,F7.4)' )                                                 
     .          I, NUC(I),RAD(I)
      ENDDO
      WRITE (2,'(A,/)') ' ---------------------------------'
      
      IF (ICDS.EQ.1) THEN
      WRITE (2,'(2(/,3X,A))') 
     $'VAN DER WAALS RADII',
     $'FOR CDS EVALUATION'
      WRITE (2,'(A)') ' ---------------------------------'
      WRITE (2,'(X,A,5X,A,3X,A)')
     .         'Center','Atomic','Radius'
      WRITE (2,'(X,A,5X,A,3X,A)')
     .         'Number','Number',' Angs'
      WRITE (2,'(A)') ' ---------------------------------'
      DO I=1, NAT
      WRITE (2,'(2X,I2,9X,I2,5X,F7.4)' )
     .          I, NUC(I),RADVDW(I)
      ENDDO
      WRITE (2,'(A,/)') 
     $' -------------------------------------'
      WRITE (2,'(/,3X,A)') 
     $'ATOMIC COMPONENTS OF SASA AND G-CDS'
      WRITE (2,'(A)') 
     $' ----------------------------------------'
      WRITE (2,'(X,A,5X,A,6X,A,6X,A)')
     $'Center','Atomic','SASA',  'G-CDS'
      WRITE (2,'(X,A,5X,A,5X,A,3X,A)')
     $'Number','Number','Angs**2','kcal/mol'
      WRITE (2,'(A)') 
     $' ----------------------------------------'
      DO I=1, NAT
      WRITE (2,'(2X,I2,9X,I2,5X,F9.4,2X,F9.4)' )
     .          I, NUC(I),ATAREA(I),CDSA(I)
      ENDDO
      WRITE (2,'(X,A,12X,F11.4,2X,F9.4)' )
     $'Total',TAREA,CDST 
      WRITE (2,'(A,/)') 
     $' ----------------------------------------'

      IF (METH.GT.0) THEN
      WRITE (2,'(/,3X,A)')
     $'CARTESIAN COORDINATES'
      WRITE (2,'(A,A)')
     $' --------------------------',
     $'-----------------------------'
      WRITE (2,'(X,A,5X,A,A)')
     $'Center','Atomic',
     $'     X            Y            Z'
      WRITE (2,'(X,A,5X,A,12X,A)')
     $'Number','Number','    Angs    '
      WRITE (2,'(A,A)')
     $' --------------------------',
     $'-----------------------------'
      DO I=1, NAT
      WRITE (2,'(2X,I2,9X,I2,1X,3(1X,F12.8))' )
     .          I, NUC(I),(CART((I-1)*3+K),K=1,3)
      ENDDO
      WRITE (2,'(A,A,/)')
     $' --------------------------',
     $'-----------------------------'

      WRITE (2,'(/,3X,A)') 
     $'CDS CONTRIBUTIONS TO GRADIENTS'
      WRITE (2,'(A,A)') 
     $' --------------------------',
     $'-----------------------------'
      WRITE (2,'(X,A,5X,A,A)')
     $'Center','Atomic',
     $'     X            Y            Z'
      WRITE (2,'(X,A,5X,A,12X,A)')
     $'Number','Number','Hartree/Bohr'
      WRITE (2,'(A,A)') 
     $' --------------------------',
     $'-----------------------------'
      DO I=1, NAT
      WRITE (2,'(2X,I2,9X,I2,1X,3(1X,F12.8))' )
     .          I, NUC(I),(DCDS((I-1)*3+K),K=1,3)
      ENDDO
      WRITE (2,'(A,A,/)') 
     $' --------------------------',
     $'-----------------------------'
      ENDIF
      ENDIF

      WRITE(2,'(A,/,A,A,/,/)')
     $' CITATION OF THE SMD SOLVATION MODEL: ',
     $' Marenich, A.V.; Cramer, C.J.; Truhlar, D.G.',
     $' J.Phys.Chem. B 2009 (in press)'       
     
      ENDIF
      WRITE(2,'(" ***************************************",        
     .               "****************************************")')      
      WRITE(2,'(30X,A)')
     $'END OF GESOL SUMMARY'       
      WRITE(2,'(" ***************************************",        
     .  "****************************************",/,/,/)')

     
C END OF WRITING A SUMMARY OF SOLVATION CALCULATION


C WRITING SOLVATION DATA FOR THE NEXT GAUSSIAN CYCLE

      OPEN (1,FILE=W70)
      WRITE (1,'(4D20.12)') E+CDST/AUTOKCAL,  
     $DPX,DPY,DPZ
      DO I=1,3*NAT,3
      WRITE (1,'(3D20.12)') (G(K)+DCDS(K),K=I,I+2)
      ENDDO
      WRITE (1,'(3D20.12,/,3D20.12)') (POL(I), I=1,6)
      DO I=1,9*NAT,3  
      WRITE (1,'(3D20.12)') (DDIP(K),K=I,I+2)
      ENDDO
      DO I=1,MF,3
      IF (I.GT.NF) GOTO 70
      IF (I+1.GT.NF) THEN
      WRITE (1,'(D20.12)') F(I)+FCDS(I)
      GOTO 70
      ENDIF
      IF (I+2.GT.NF) THEN 
      WRITE (1,'(2D20.12)') (F(K)+FCDS(K),K=I,I+1)
      GOTO 70
      ENDIF
      WRITE (1,'(3D20.12)') (F(K)+FCDS(K),K=I,I+2)
      ENDDO
70    CONTINUE
      CLOSE (1)
      CLOSE (4,STATUS='DELETE')
      STOP

C END OF WRITING SOLVATION DATA FOR THE NEXT GAUSSIAN CYCLE


C ERROR MESSAGES

75    CONTINUE
      WRITE (2,'(A,A)') ' ERROR IN gesol_external_out_f:',
     $' INCOMPLETE DATA FOR CDS CONTRIBUTION TO ENERGY! STOP.'
      WRITE (2,*)
      STOP
80    CONTINUE
      WRITE (2,'(A,A)') ' ERROR IN gesol_external_out_f:',
     $' INCOMPLETE DATA FOR CDS CONTRIBUTION TO GRADIENT! STOP.'
      WRITE (2,*)
      STOP
85    CONTINUE
      WRITE (2,'(A,A)') ' ERROR IN gesol_external_out_f:',
     $' INCOMPLETE DATA FOR CDS CONTRIBUTION TO HESSIAN! STOP.'
      WRITE (2,*)
      STOP

C END OF ERROR MESSAGES


      END



      SUBROUTINE CAPS(WLNS)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*(*) WLNS
      ILN=LENTRIM_USR(WLNS)
      IUPA=ICHAR('A')
      IDNA=ICHAR('a') 
      IDNZ=ICHAR('z')
      IK=0
      DO I=1,ILN
      IC=ICHAR(WLNS(I:I))
      IF(IC.GE.IDNA.AND.IC.LE.IDNZ) WLNS(I:I)=CHAR(IC-IDNA+IUPA)
      IF(WLNS(I:I).NE.' ') THEN
      IK=IK+1 
      IF (IK.NE.I) WLNS(IK:IK)=WLNS(I:I)
      END IF   
      ENDDO
      IF (IK.LT.ILN) WLNS(IK+1:ILN)=' '
      RETURN
      END

      INTEGER FUNCTION LENTRIM_USR(WLINE)
      CHARACTER*(*) WLINE  
      ITL=LEN(WLINE)  
      IN=0
      DO I=1,ITL
      IC=ITL-I+1
      IF (WLINE(IC:IC).NE.' ') THEN
       IN=IC
       GO TO 1
      END IF
      END DO  
  1   LENTRIM_USR=IN
      RETURN   
      END 


     

      

            



