      SUBROUTINE UPJFC(JFC,JFC2,JFC3,SCR1,SCR2,NCOORD,NIRREP,UPDATE)
C
CEND
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DOUBLE PRECISION JFC,JFC2,JFC3,MPROTON,NINE
      LOGICAL UPDATE 
C
      DIMENSION JFC(NCOORD,NCOORD),JFC2(3*NCOORD,3*NCOORD),
     &          JFC3(3*NCOORD,3*NCOORD),SCR1(1),SCR2(1)
C
      COMMON/MACHSP/IINTLN,IFLTLN,IINTFP,IALOBE,IBITWD
C
      DATA IONE/1/
      DATA ONE,TWO,FOUR,NINE/1.D0,2.D0,4.D0,9.D0/
C
C C: VELOCITY OF LINGHT IN A.U.
C
      DATA C /137.035987D0/
C
C MPROTON: MASS OF PROTON IN A.U.
C
      DATA MPROTON /1836.152736D0/
C
C CONVERT: CONVERSION FROM A.U. TO SEC  (FOR TIME UNITS)
C
      DATA  CONVERT /2.4188843D-17/
C
      DATA PI /3.141592654D0/
C
C CONVERSION OF CALCULATED COUPLING TENSOR TO THE USUAL UNITS (HZ)
C
      FACT=FOUR/((MPROTON**2)*(C**4)*CONVERT*TWO*NINE)*PI
C
      CALL SSCAL(NCOORD*NCOORD,FACT,JFC,1)
C
      IF(NIRREP.NE.1) THEN
C 
       CALL ZERO(JFC2,NCOORD*NCOORD)
       CALL TRAHES(JFC,JFC2,SCR1,SCR2,NCOORD)
c YAU : old
c      CALL ICOPY(NCOORD*NCOORD*IINTFP,JFC2,1,JFC,1)
c YAU : new
       CALL DCOPY(NCOORD*NCOORD,JFC2,1,JFC,1)
c YAU : end
C
      ENDIF
C
      CALL EXPJFC(JFC,JFC2,NCOORD)
C
      CALL GETREC(20,'JOBARC','NINDATOM',IONE,NUCIND)
      CALL GETREC(20,'JOBARC','MULTATOM',NUCIND,SCR1)
      CALL GETREC(20,'JOBARC','NAMCOORD',IINTFP*3*NUCIND,
     &            SCR1(1+NUCIND))
C
      CALL JPRI(JFC2,3*NCOORD,NUCIND,SCR1,SCR1(1+NUCIND),SCR2,.TRUE.)
C
      IF(UPDATE) THEN
 
       OPEN(UNIT=81,FILE='JFC',STATUS='OLD',FORM='FORMATTED')
       DO 2000 ICOORD=1,3*NCOORD
        READ(81,3001) (JFC3(ICOORD,J),J=1,3*NCOORD)
2000   CONTINUE
3000   FORMAT(2I5)
3001   FORMAT(3F20.10)
       CALL SAXPY(9*NCOORD*NCOORD,ONE,JFC3,1,JFC2,1)
      ELSE
       OPEN(UNIT=81,FILE='JFC',STATUS='UNKNOWN',FORM='FORMATTED')
      ENDIF
C
      REWIND(81)
      DO 2100 ICOORD=1,3*NCOORD
       WRITE(81,3001) (JFC2(ICOORD,J),J=1,3*NCOORD)
2100  CONTINUE
      CLOSE(UNIT=81,STATUS='KEEP')
C
      RETURN
      END
