      SUBROUTINE DUMPPERT(VALUE,N,POLAR,DDP,FCM,JFC,JSD,NGEOM,
     &                    ICORE,DOPOL,DODDP,DOFCM,DOJFC,DOJSD,
     &                    ITRANS,IMAP,NUCIND)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER DIRPRD
      DOUBLE PRECISION JFC,JSD
      LOGICAL DOPOL,DODDP,DOFCM,DOJFC,DOJSD,TRAINV
C
      DIMENSION VALUE(N,N),POLAR(3,3),DDP(3,NGEOM),
     &          FCM(NGEOM,NGEOM),JFC(NGEOM,NGEOM),
     &          JSD(NGEOM,NGEOM),ICORE(1),IMAP(1),ITRANS(1) 
C
      COMMON/MACHSP/IINTLN,IFLTLN,IINTFP,IALONE,IBITWD
      COMMON/SYMINF/NSTART,NIRREP,IRREPA(255,2),DIRPRD(8,8)
      COMMON/PERT1/STERM,NSP
      COMMON/PERT2/NTP,NTPERT(8),NSPERT(8),IPERT(8)
      COMMON/PERT3/IXYZSYM(3) 
      COMMON/INVAR/TRAINV
C
C  LOOP OVER ALL IRREPS
C
      IF(DOFCM) CALL IZERO(FCM,NGEOM*NGEOM*IINTFP)
      IF(DODDP) CALL IZERO(DDP,3*NGEOM*IINTFP)
      IF(DOPOL) CALL IZERO(POLAR,9*IINTFP)
      IF(DOJFC) CALL IZERO(JFC,NGEOM*NGEOM*IINTFP)
      IF(DOJSD) CALL IZERO(JSD,NGEOM*NGEOM*IINTFP)
      IOFFF=0
      IOFFG=0
C
      DO 1000 IRREP=1,NIRREP
C
       NT=NTPERT(IRREP)
       NS=NSPERT(IRREP)
       IOFF=IPERT(IRREP)
C
       IF(DOFCM) THEN
C
        DO 100 IPERT1=1,NS
C
         JPERT1=IPERT1+IOFF
         KPERT1=IMAP(IPERT1+IOFFG)
C
         DO 100 IPERT2=1,NS
C
          JPERT2=IPERT2+IOFF
          KPERT2=IMAP(IPERT2+IOFFG)
C
          FCM(KPERT1,KPERT2)=VALUE(JPERT1,JPERT2)
C
100     CONTINUE
C
       ENDIF
C
       IF(DODDP) THEN
C
        DO 200 IPERT1=1,NS
C
         JPERT1=IPERT1+IOFF
         KPERT1=IMAP(IPERT1+IOFFG)
 
         DO 200 IPERT2=NS+1,NT
C
          JPERT2=IPERT2+IOFF
          KPERT2=IXYZSYM(IPERT2-NS+IOFFF)
C
          DDP(KPERT2,KPERT1)=VALUE(JPERT2,JPERT1)
C
200     CONTINUE
C
       ENDIF
C
       IF(DOPOL) THEN
C
        DO 300 IPERT1=NS+1,NT
C
         JPERT1=IPERT1+IOFF
         KPERT1=IXYZSYM(IPERT1-NS+IOFFF)
C
         DO 300 IPERT2=NS+1,NT
C
          JPERT2=IPERT2+IOFF
          KPERT2=IXYZSYM(IPERT2-NS+IOFFF)
C
          POLAR(KPERT1,KPERT2)=-VALUE(JPERT1,JPERT2)
C
300     CONTINUE
C
       ENDIF
C
       IF(DOJFC) THEN
C
        DO 400 IPERT1=1,NT
C
         JPERT1=IOFF+IPERT1
C
         DO 400 IPERT2=1,NT
C
          JPERT2=IOFF+IPERT2
C
          JFC(JPERT1,JPERT2)=VALUE(JPERT1,JPERT2)
C
400     CONTINUE
C
       ENDIF
C
       IF(DOJSD) THEN
C
        DO 500 IPERT1=1,NT
C
         JPERT1=IOFF+IPERT1
C
         DO 500 IPERT2=1,NT
C
          JPERT2=IOFF+IPERT2
C
          JSD(JPERT1,JPERT2)=VALUE(JPERT1,JPERT2)
C
500     CONTINUE
C
       ENDIF
C
       IOFFG=IOFFG+NS
       IOFFF=IOFFF+NT-NS
C
1000  CONTINUE
C
      IF(DOFCM) THEN
C
C UPDATE FCM FILE
C
       IF(TRAINV) THEN
C
C USE TRANSLATIONAL INVARIANCE TO CREATE FULL FCM CONTRIBUTION
C
        CALL EXPFCM(FCM,NGEOM,ITRANS,NUCIND)
C
        IOFFG=IOFFG+3
C
       ENDIF
C
       ISCR1=1+IOFFG*IOFFG*IINTFP
       ISCR2=ISCR1+IOFFG*IOFFG*IINTFP
       CALL UPFCM(FCM,ICORE,ICORE(ISCR1),ICORE(ISCR2),IOFFG,NIRREP,
     &            .TRUE.)
C
      ENDIF
C
      IF(DODDP) THEN
C
C UPDATE DIPDER FILE
C
       IF(TRAINV) THEN
C
C CREATE FULL DIPDER CONTRIBUTION USING TRANSLATIONAL INVARIANCE
C
        CALL EXPDDP(DDP,NGEOM,ITRANS,NUCIND)
C
       ENDIF
C
       ISCR1=1+IINTFP*3*IOFFG
       CALL UPDDP(DDP,ICORE,ICORE(ISCR1),IOFFG,NIRREP,.TRUE.)
C
      ENDIF 
C
      IF(DOPOL) THEN
C
C UPDATE POLARISABILITY FILE
C
       CALL UPPOL(POLAR,ICORE,.TRUE.)
C
      ENDIF
C
      IF(DOJFC) THEN
C
       IOFFG=NGEOM
       IJFC2=1
       IJFC3=IJFC2+IINTFP*9*IOFFG*IOFFG
       ISCR1=1+9*IOFFG*IOFFG*IINTFP
       ISCR2=ISCR1+9*IOFFG*IOFFG*IINTFP
       CALL UPJFC(JFC,ICORE(IJFC2),ICORE(IJFC3),ICORE(ISCR1),
     &            ICORE(ISCR2),IOFFG,NIRREP,.TRUE.)
C
      ENDIF
C
      IF(DOJSD) THEN
C
       IOFFG=NGEOM
       IJSD2=1
       IJSD3=IJSD2+IINTFP*IOFFG*IOFFG
       ISCR1=1+9*IOFFG*IOFFG*IINTFP
       ISCR2=ISCR1+9*IOFFG*IOFFG*IINTFP
       CALL UPJSD(JSD,ICORE(IJSD2),ICORE(IJSD3),ICORE(ISCR1),
     &            ICORE(ISCR2),IOFFG,NIRREP,.TRUE.)
C
      ENDIF
C
      RETURN
      END
