Sources Esope | Cast3M

ntap17
C NTAP17    SOURCE    CHAT      05/01/13    02:02:03     5004
      SUBROUTINE NTAP17(IVFP,IVFQ,IVXU,IVXL,IVLAMB,IVB,IBU,IBL,VF0,
     * NDR,N,MCP,MCQ,M,XL,XLL,ILOG1,NPDR,MVDU,MVDL,ITI,ITK,VFPMAX,
     * IVN,IVD)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMLREEL
-INC TMXMAT
-INC SMLENTI
      POINTEUR MLREE4.MLREEL,MLREE5.MLREEL
      POINTEUR MLREE6.MLREEL,MLREE7.MLREEL
      LOGICAL ILOG1
      N11=N+1
      VFPMAX=-1.D-20
      MLENT1=ITI
      MLENT2=ITK
      LDIM1=NPDR
      LDIM2=2
      SEGINI MXMAT,MXMA3
      MXMA1=MVDU
      MXMA2=MVDL
      DO 1 I=1,NPDR
         XMAT(I,1)=MXMA1.XMAT(MLENT1.LECT(I),MLENT2.LECT(I)-1)
         XMAT(I,2)=MXMA1.XMAT(MLENT1.LECT(I),MLENT2.LECT(I))
         MXMA3.XMAT(I,1)=MXMA2.XMAT(MLENT1.LECT(I),MLENT2.LECT(I)-1)
         MXMA3.XMAT(I,2)=MXMA2.XMAT(MLENT1.LECT(I),MLENT2.LECT(I))
    1 CONTINUE
*  SAUVEGARDE DE IVXU,IVXL
      MLREEL=IVXU
      MLREE1=IVXL
      MLREE6=IVFP
      MLREE7=IVFQ
      SEGACT MLREEL,MLREE1,MLREE6,MLREE7
      JG=PROG(/1)
      SEGINI MLREE4,MLREE5
      IBBU=MLREE4
      IBBL=MLREE5
      SEGINI MLREE2,MLREE3
      IBU=MLREE2
      IBL=MLREE3
      DO 2 I=0,(2**NPDR)-1
      DO 10 J=1,JG
         MLREE4.PROG(J)=PROG(J)
         MLREE5.PROG(J)=MLREE1.PROG(J)
   10 CONTINUE
*
******** CONVERSION DE I EN BINAIRE **************
*
         K=I
         JG=NPDR
         SEGINI MLENTI
         DO 3 J=NPDR-1,0,-1
            LECT(J+1)=INT(K/(2**J))
            K=K-(2**J)*LECT(J+1)
    3    CONTINUE
*
*** DANS MLENTI(I) ON A LE CODAGE: 0 POUR X(K-1) POUR LA VARIABLE I
*                                : 1 POUR X(K)
*   QUI N'EST PAS FIXEE
*
         DO 4 J=1,NPDR
            MLREE4.PROG(MLENT1.LECT(J))=XMAT(J,LECT(J)+1)
            MLREE5.PROG(MLENT1.LECT(J))=MXMA3.XMAT(J,LECT(J)+1)
    4    CONTINUE
*
* CALCUL DE LA VALEUR DE LA FONCTION PRIMALE VFP DE X
*
         VFP=0.
         DO 5 J = 1,N11
           X1=MLREE4.PROG(J)
           X2=MLREE5.PROG(J)
           IF(MLREE4.PROG(J).LT.1.D-15) X1=1.D-15
           IF(MLREE5.PROG(J).LT.1.D-15) X2=1.D-15
           VFP=VFP+(MLREE6.PROG(J)/X1)+(MLREE7.PROG(J)/X2)
    5    CONTINUE
*
*RECHERCHE DU MAX  DE VFP AUTOUR DU POINT COURANT
*
         IF(VFP.GT.VFPMAX) THEN
            VFPMAX=VFP
            DO 20 J=1,N11
              MLREE2.PROG(J)=MLREE4.PROG(J)
              MLREE3.PROG(J)=MLREE5.PROG(J)
   20       CONTINUE
         ENDIF
    2 CONTINUE
      MLREE2=IBU
      MLREE3=IBL
      SEGACT MLREE2,MLREE3
      IF(IIMPI.EQ.1799) WRITE(IOIMP,FMT='('' VALEURS DE X APRES SELECT
     *ION = IBU :'',/,(1X,5E12.5))')(MLREE2.PROG(I),I=1,N11)
      IF(IIMPI.EQ.1799) WRITE(IOIMP,FMT='('' VALEURS DE X APRES SELECT
     *ION = IBL :'',/,(1X,5E12.5))')(MLREE3.PROG(I),I=1,N11)
*
************************************************************************
*
      XLL=XL
      XL=0.D0
      MLREEL=IVN
      MLREE1=IVD
      MLREE4=IVXU
      MLREE5=IVXL
      SEGACT MLREEL,MLREE1,MLREE4,MLREE5
      DO 6 I = 1,N11
           X1=MLREE4.PROG(J)
           X2=MLREE5.PROG(J)
           IF(MLREE4.PROG(J).LT.1.D-15) X1=1.D-15
           IF(MLREE5.PROG(J).LT.1.D-15) X2=1.D-15
           XL=XL +(PROG(I)/X1)+(MLREE1.PROG(I)/X2)
    6 CONTINUE
      MLREEL=IVB
      MLREE1=IVLAMB
      DO 7 I=1,M
        XL=XL+PROG(I)*MLREE1.PROG(I)
    7 CONTINUE
*
      ILOG1=.FALSE.
      IF( XL.GT.VFPMAX) THEN
         ILOG1= .TRUE.
      ELSE
         IF( XLL.LT.XL)THEN
            ILOG1=.TRUE.
         ENDIF
      ENDIF
      IF( NDR.EQ.0) THEN
          ILOG1=.TRUE.
      ENDIF
      NDR=NDR + 1
      RETURN
      END