C CALPIN    SOURCE    CB215821  16/04/21    21:15:30     8920
C CALPIN     SOURCE    INSL       24/10/96
      SUBROUTINE CALPIN(IFOU,STRN,SIGM,SIGR,S1,DEP,NSTRS,EBC,
     1 AA,BB,DK1,DK2,ILOI,RB,EX,PXY)
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION S1(NSTRS),DFSI(6),STRN(NSTRS),DGSI(6),SIGR(NSTRS)
      DIMENSION DEP(NSTRS,NSTRS),D6(6,6),DP(6,6),S(6)
      DIMENSION SS(100,6),CR(100,3),SIGM(NSTRS)
C-------------------------------------------------------------------
C      WRITE(*,*) '****  ON EST DANS CALPIN ******'
C-------------------------------------------------------------------
      CALL ZERO(S1,NSTRS,1)
      CALL ZERO(DEP,NSTRS,NSTRS)
C-------------------------------------------------------------------
      TU=RB
      PRB=1.D-5
      NIB=2
      ICHOI=1
      IPREM=0
C-------------------------------------------------------------------
      BETC=EBC/EX
C-------------------------------------------------------------------
      PAEC0=EBC/(1.D0-BETC)
      CALL CRIOTO(SIGR,SEQ,FCRI,NSTRS,TU,AA,BB,DK1,DK2)
      IF(SEQ.LT.1.D-10) IPREM=1
      IF(SEQ.GT.TU) SEQ=TU
C-------------------------------------------------------------------
      DO 10 I=1,NSTRS
        IF(IPREM.EQ.0) THEN
          S1(I)=SIGR(I)
        ELSE
          S1(I)=SIGR(I)+SIGM(I)
        ENDIF
  10  CONTINUE
C-------------------------------------------------------------------
      IF(IPREM.EQ.1) THEN
        IF(NIB.EQ.1) NIB = 10
        CALL CRIOTO(S1,SEQ,FCRI,NSTRS,TU,AA,BB,DK1,DK2)
      ENDIF
C-------------------------------------------------------------------
      SEQ0=SEQ
      CALL ZERO(CR,100,3)
      CALL ZERO(SS,100,6)
C-------------------------------------------------------------------
      DO 1 II=1,NIB
      SEQ1=SEQ
C-------------------------------------------------------------------
C         **************************************
C         * BOUCLE SUR LES ITERATIONS INTERNES *
C         **************************************
C-------------------------------------------------------------------
      IF(SEQ.LT.1.D-10) THEN
         CALL ZERO(DEP,NSTRS,NSTRS)
         GOTO 40
      ENDIF
      CALL DFSIG(S1,DFSI,DGSI,SEQ1,NSTRS,RB,AA,BB,DK1,DK2,ILOI)
      H2=0.D0
      DO 92 I=1,NSTRS
        H2=H2+DFSI(I)*DGSI(I)
   92 CONTINUE
      PAEC=PAEC0*H2
C-------------------------------------------------------------------
      CALL DEPO(S1,DEP,PAEC,SEQ1,NSTRS,IFOU,D6,DP,EX,PXY,AA,BB,
     & DK1,DK2,RB,ILOI)
C-------------------------------------------------------------------
   40 CONTINUE
      CALL BST(DEP,STRN,NSTRS,NSTRS,S)
      DO 45 I=1,NSTRS
        S1(I)=SIGR(I)+S(I)
   45 CONTINUE
      CALL CRIOTO(S1,SEQ,FCRI,NSTRS,SEQ1,AA,BB,DK1,DK2)
C---------------------------------------------------------------------
      IF(ABS(FCRI).LT.PRB) GOTO 7
      DO 4 J=1,NSTRS
         SS(II,J)=S1(J)
    4 CONTINUE
      CR(II,1)=FCRI
      CR(II,2)=SEQ
      CR(II,3)=PAEC
C-------------------------------------------------------------------
C         ************************************************
C         * FIN DE LA BOUCLE SUR LES ITERATIONS INTERNES *
C         ************************************************
    1 CONTINUE
C--------------------------------------------------------------------------
      DMMN1=ABS(CR(1,1))
      NO=1
      DO 5 J=1,NIB
       ACR=ABS(CR(J,1))
       IF(DMMN1 .GE. ACR) THEN
         DMMN1=ABS(CR(J,1))
         NO=J
       ENDIF
    5 CONTINUE
      DO 6 J=1,NSTRS
        S1(J)=SS(NO,J)
        IF(ABS(S1(I)).LT.1.D-8) S1(I)=0.D0
    6 CONTINUE
        SEQ=CR(NO,2)
        PAEC=CR(NO,3)
    7 CONTINUE
C----------------------------------------------------------------------
      IF(SEQ.GT.TU) SEQ=TU
      CALL DEPO(S1,DEP,PAEC,SEQ,NSTRS,IFOU,D6,DP,EX,PXY,AA,BB,
     1 DK1,DK2,RB,ILOI)
C--------------------------------------------------------------------------
  200 CONTINUE
C--------------------------------------------------------------------------
1991  FORMAT(18(1X,E12.5))
C--------------------------------------------------------------------------
      RETURN
      END