Sources Esope | Cast3M

ntap21
C NTAP21    SOURCE    CHAT      05/01/13    02:02:08     5004
      SUBROUTINE NTAP21(IVFP,IVFQ,IVLAMB,IVB,IBU,IBL,
     * NPDR,N,MCP,MCQ,M,MVDU,MVDL,ITI,ITK)
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 NORMP,NORMPM
      LOGICAL ADMI,UNAD
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
-INC SMLREEL
-INC TMXMAT
-INC SMLENTI
      POINTEUR MLREE4.MLREEL,MLREE5.MLREEL
      POINTEUR MLREE6.MLREEL,MLREE7.MLREEL,MLREE8.MLREEL
*
      UNAD=.FALSE.
      VFPMIN=XGRAND
      NORMPM=XGRAND
      N11=N+1
      MLENT1=ITI
      MLENT2=ITK
      LDIM1=NPDR
      LDIM2=2
      SEGINI MXMAT,MXMA1
      MXMA2=MVDU
      MXMA3=MVDL
      SEGACT MXMA2,MXMA3
      DO 1 I=1,NPDR
        XMAT(I,1)=MXMA2.XMAT(MLENT1.LECT(I),MLENT2.LECT(I)-1)
        XMAT(I,2)=MXMA2.XMAT(MLENT1.LECT(I),MLENT2.LECT(I))
        MXMA1.XMAT(I,1)=MXMA3.XMAT(MLENT1.LECT(I),MLENT2.LECT(I)-1)
        MXMA1.XMAT(I,2)=MXMA3.XMAT(MLENT1.LECT(I),MLENT2.LECT(I))
    1 CONTINUE
      MLREEL=IBU
      SEGACT MLREEL
      JG=PROG(/1)
      SEGINI MLREE6,MLREE7
      SEGINI MLREE4,MLREE5
      SEGINI MLREE2,MLREE3
      IBBU=MLREE2
      IBBL=MLREE3
      DO 2 I=0,(2**NPDR)-1
      ADMI=.TRUE.
*
*  SAUVEGARDE DE IBU,IBL
*
         MLREEL=IBU
         MLREE1=IBL
         SEGACT MLREEL,MLREE1
         DO 10 J=1,N11
           MLREE4.PROG(J)=PROG(J)
           MLREE5.PROG(J)=MLREE1.PROG(J)
   10    CONTINUE
*
         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
         DO 4 J=1,NPDR
           MLREE4.PROG(MLENT1.LECT(J))=XMAT(J,LECT(J)+1)
           MLREE5.PROG(MLENT1.LECT(J))=MXMA1.XMAT(J,LECT(J)+1)
    4    CONTINUE
*
*  TEST SI IBU,IBL EST UN PT DUAL ADMISSIBLE
*
         JG=MLREE4.PROG(/1)
         SEGINI MLREEL,MLREE1
         DO 41 J=1,N11
            PROG(J)=1.D0/MLREE4.PROG(J)
            MLREE1.PROG(J)=1.D0/MLREE5.PROG(J)
   41    CONTINUE
         MXMA2=MCP
         MXMA3=MCQ
         CALL MATVE1(MXMA2.XMAT,PROG,M,N11,MLREE6.PROG,2)
         CALL MATVE1(MXMA3.XMAT,MLREE1.PROG,M,N11,MLREE7.PROG,2)
         MLREE8=IVB
         NORMP=0.D0
         DO 42 J=1,M
          DIF=MLREE6.PROG(J)+MLREE7.PROG(J)-MLREE8.PROG(J)
          IF(DIF.GT.0.D0)THEN
              IF(UNAD) GO TO 2
              ADMI=.FALSE.
              NORMP=NORMP+(DIF**2)
          ENDIF
   42    CONTINUE
*
* CALCUL DE LA VALEUR DE LA FONCTION PRIMALE VFP DE X
*
         IF(ADMI) THEN
      IF(IIMPI.EQ.1799)
     *WRITE(IOIMP,FMT='( '' POINT  ADMISSIBLE '' )')
            MLREE6=IVFP
            MLREE7=IVFQ
            SEGACT MLREE6,MLREE7
            VFP=0.
            DO 5 J = 1,N11
              VFP=VFP+(PROG(J)*MLREE6.PROG(J))+
     *         (MLREE1.PROG(J)*MLREE7.PROG(J))
    5       CONTINUE
            UNAD=.TRUE.
*
* RECHERCHE DU MIN  DE VFP POUR LES PTS ADMISSIBLES
*
         IF(VFP.LT.VFPMIN) THEN
            VFPMIN=VFP
            DO 20 J=1,N11
              MLREE2.PROG(J)=MLREE4.PROG(J)
              MLREE3.PROG(J)=MLREE5.PROG(J)
   20       CONTINUE
         ENDIF
         ENDIF
*
* RECHERCHE  DU PT QUI RESPECTE AU MIEUX LES CONTRAINTES SI PAS DE SOL
*
         IF(.NOT.UNAD)THEN
         IF(NORMP.LT.NORMPM) THEN
            NORMPM=NORMP
            DO 21 J=1,N11
              MLREE2.PROG(J)=MLREE4.PROG(J)
              MLREE3.PROG(J)=MLREE5.PROG(J)
   21       CONTINUE
         ENDIF
         ENDIF
    2 CONTINUE
      IF(.NOT.UNAD) THEN
      IF(IIMPI.EQ.1799)
     *WRITE(IOIMP,FMT='( '' PAS DE POINT ADMISSIBLE '' )')
      ENDIF
      MLREEL=IBBU
      MLREE1=IBBL
      MLREE2=IBU
      MLREE3=IBL
      SEGACT MLREEL,MLREE1,MLREE2,MLREE3
      DO 30 I=1,N11
         MLREE2.PROG(I)=PROG(I)
         MLREE3.PROG(I)=MLREE1.PROG(I)
   30 CONTINUE
      IF(IIMPI.EQ.1799) WRITE(IOIMP,FMT='('' VALEURS DE X DANS ETAP21
     * = IBU :'',/,(1X,5E12.5))')(MLREE2.PROG(I),I=1,N11)
      IF(IIMPI.EQ.1799) WRITE(IOIMP,FMT='('' VALEURS DE X DANS ETAP21
     * = IBL :'',/,(1X,5E12.5))')(MLREE3.PROG(I),I=1,N11)
      RETURN
      END