Esope source files

   1 : C CALPIN    SOURCE    CHAT      05/01/12    21:47:53     5004           
   2 : C CALPIN     SOURCE    INSL       24/10/96    
   3 :       SUBROUTINE CALPIN(IFOU,STRN,SIGM,SIGR,S1,DEP,NSTRS,EBC,
   4 :      1 AA,BB,DK1,DK2,ILOI,RB,EX,PXY)
   5 : C
   6 :       IMPLICIT INTEGER(I-N)
   7 :       IMPLICIT REAL*8(A-H,O-Z)
   8 :       DIMENSION S1(NSTRS),DFSI(6),STRN(NSTRS),DGSI(6),SIGR(NSTRS)
   9 :       DIMENSION DEP(NSTRS,NSTRS),D6(6,6),DP(6,6),S(6)
  10 :       DIMENSION SS(100,6),CR(100,3),SIGM(NSTRS)
  11 : C-------------------------------------------------------------------
  12 : C      WRITE(*,*) '****  ON EST DANS CALPIN ******'
  13 : C-------------------------------------------------------------------
  13 :       CALL ZERO(S1,NSTRS,1)
  13 :       CALL ZERO(DEP,NSTRS,NSTRS)
  14 : C-------------------------------------------------------------------
  15 :       TU=RB
  16 :       PRB=1.D-5
  17 :       NIB=2
  18 :       ICHOI=1
  19 :       IPREM=0
  20 : C-------------------------------------------------------------------
  21 :       BETC=EBC/EX
  22 : C-------------------------------------------------------------------
  23 :       PAEC0=EBC/(1.D0-BETC)
  23 :       CALL CRIOTO(SIGR,SEQ,FCRI,NSTRS,TU,AA,BB,DK1,DK2)
  24 :       IF(SEQ.LT.1.D-10) IPREM=1
  25 :       IF(SEQ.GT.TU) SEQ=TU
  26 : C-------------------------------------------------------------------
  27 :       DO 10 I=1,NSTRS
  28 :         IF(IPREM.EQ.0) THEN
  29 :           S1(I)=SIGR(I)
  30 :         ELSE
  31 :           S1(I)=SIGR(I)+SIGM(I)
  32 :         ENDIF
  33 :   10  CONTINUE
  34 : C-------------------------------------------------------------------
  35 :       IF(IPREM.EQ.1) THEN
  36 :         IF(NIB.EQ.1) NIB = 10
  36 :         CALL CRIOTO(S1,SEQ,FCRI,NSTRS,TU,AA,BB,DK1,DK2)
  37 :       ENDIF
  38 : C-------------------------------------------------------------------
  39 :       SEQ0=SEQ
  39 :       CALL ZERO(CR,100,3)
  39 :       CALL ZERO(SS,100,6)
  40 : C-------------------------------------------------------------------
  41 :       DO 1 II=1,NIB
  42 :       SEQ1=SEQ
  43 : C-------------------------------------------------------------------
  44 : C         **************************************
  45 : C         * BOUCLE SUR LES ITERATIONS INTERNES *
  46 : C         **************************************
  47 : C-------------------------------------------------------------------
  48 :       IF(SEQ.LT.1.D-10) THEN
  48 :          CALL ZERO(DEP,NSTRS,NSTRS)
  49 :          GOTO 40
  50 :       ENDIF
  50 :       CALL DFSIG(S1,DFSI,DGSI,SEQ1,NSTRS,RB,AA,BB,DK1,DK2,ILOI)
  51 :       H2=0.D0
  52 :       DO 92 I=1,NSTRS
  53 :         H2=H2+DFSI(I)*DGSI(I)
  54 :    92 CONTINUE
  55 :       PAEC=PAEC0*H2
  56 : C-------------------------------------------------------------------
  56 :       CALL DEPO(S1,DEP,PAEC,SEQ1,NSTRS,IFOU,D6,DP,EX,PXY,AA,BB,
  57 :      & DK1,DK2,RB,ILOI)
  58 : C-------------------------------------------------------------------
  59 :    40 CONTINUE
  59 :       CALL BST(DEP,STRN,NSTRS,NSTRS,S)
  60 :       DO 45 I=1,NSTRS
  61 :         S1(I)=SIGR(I)+S(I)
  62 :    45 CONTINUE
  62 :       CALL CRIOTO(S1,SEQ,FCRI,NSTRS,SEQ1,AA,BB,DK1,DK2)
  63 : C---------------------------------------------------------------------
  64 :       IF(DABS(FCRI).LT.PRB) GOTO 7
  65 :       DO 4 J=1,NSTRS
  66 :          SS(II,J)=S1(J)
  67 :     4 CONTINUE
  68 :       CR(II,1)=FCRI
  69 :       CR(II,2)=SEQ
  70 :       CR(II,3)=PAEC
  71 : C-------------------------------------------------------------------
  72 : C         ************************************************
  73 : C         * FIN DE LA BOUCLE SUR LES ITERATIONS INTERNES *
  74 : C         ************************************************
  75 :     1 CONTINUE
  76 : C--------------------------------------------------------------------------
  77 :       DMMN1=DABS(CR(1,1))
  78 :       NO=1
  79 :       DO 5 J=1,NIB
  80 :        ACR=DABS(CR(J,1))
  81 :        IF(DMMN1 .GE. ACR) THEN
  82 :          DMMN1=DABS(CR(J,1))
  83 :          NO=J
  84 :        ENDIF
  85 :     5 CONTINUE
  86 :       DO 6 J=1,NSTRS
  87 :         S1(J)=SS(NO,J)
  88 :         IF(DABS(S1(I)).LT.1.D-8) S1(I)=0.D0
  89 :     6 CONTINUE
  90 :         SEQ=CR(NO,2)
  91 :         PAEC=CR(NO,3)
  92 :     7 CONTINUE
  93 : C----------------------------------------------------------------------
  94 :       IF(SEQ.GT.TU) SEQ=TU
  94 :       CALL DEPO(S1,DEP,PAEC,SEQ,NSTRS,IFOU,D6,DP,EX,PXY,AA,BB,
  95 :      1 DK1,DK2,RB,ILOI)
  96 : C--------------------------------------------------------------------------
  97 :   200 CONTINUE
  98 : C--------------------------------------------------------------------------
  99 : 1991  FORMAT(18(1X,E12.5))
 100 : C--------------------------------------------------------------------------
 101 :       RETURN
 102 :       END
 103 :  
 104 :