1 : C NTAP21 SOURCE CHAT 05/01/13 02:02:08 5004 2 : SUBROUTINE NTAP21(IVFP,IVFQ,IVLAMB,IVB,IBU,IBL, 3 : * NPDR,N,MCP,MCQ,M,MVDU,MVDL,ITI,ITK) 4 : * 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8(A-H,O-Z) 7 : REAL*8 NORMP,NORMPM 8 : LOGICAL ADMI,UNAD 9 : -INC CCOPTIO 10 : -INC CCREEL 11 : -INC SMLREEL 12 : -INC TMXMAT 13 : -INC SMLENTI 14 : POINTEUR MLREE4.MLREEL,MLREE5.MLREEL 15 : POINTEUR MLREE6.MLREEL,MLREE7.MLREEL,MLREE8.MLREEL 16 : * 17 : UNAD=.FALSE. 18 : VFPMIN=XGRAND 19 : NORMPM=XGRAND 20 : N11=N+1 21 : MLENT1=ITI 22 : MLENT2=ITK 23 : LDIM1=NPDR 24 : LDIM2=2 25 : SEGINI MXMAT,MXMA1 26 : MXMA2=MVDU 27 : MXMA3=MVDL 28 : SEGACT MXMA2,MXMA3 29 : DO 1 I=1,NPDR 30 : XMAT(I,1)=MXMA2.XMAT(MLENT1.LECT(I),MLENT2.LECT(I)-1) 31 : XMAT(I,2)=MXMA2.XMAT(MLENT1.LECT(I),MLENT2.LECT(I)) 32 : MXMA1.XMAT(I,1)=MXMA3.XMAT(MLENT1.LECT(I),MLENT2.LECT(I)-1) 33 : MXMA1.XMAT(I,2)=MXMA3.XMAT(MLENT1.LECT(I),MLENT2.LECT(I)) 34 : 1 CONTINUE 35 : MLREEL=IBU 36 : SEGACT MLREEL 37 : JG=PROG(/1) 38 : SEGINI MLREE6,MLREE7 39 : SEGINI MLREE4,MLREE5 40 : SEGINI MLREE2,MLREE3 41 : IBBU=MLREE2 42 : IBBL=MLREE3 43 : DO 2 I=0,(2**NPDR)-1 44 : ADMI=.TRUE. 45 : * 46 : * SAUVEGARDE DE IBU,IBL 47 : * 48 : MLREEL=IBU 49 : MLREE1=IBL 50 : SEGACT MLREEL,MLREE1 51 : DO 10 J=1,N11 52 : MLREE4.PROG(J)=PROG(J) 53 : MLREE5.PROG(J)=MLREE1.PROG(J) 54 : 10 CONTINUE 55 : * 56 : K=I 57 : JG=NPDR 58 : SEGINI MLENTI 59 : DO 3 J=NPDR-1,0,-1 60 : LECT(J+1)=INT(K/(2**J)) 61 : K=K-(2**J)*LECT(J+1) 62 : 3 CONTINUE 63 : DO 4 J=1,NPDR 64 : MLREE4.PROG(MLENT1.LECT(J))=XMAT(J,LECT(J)+1) 65 : MLREE5.PROG(MLENT1.LECT(J))=MXMA1.XMAT(J,LECT(J)+1) 66 : 4 CONTINUE 67 : * 68 : * TEST SI IBU,IBL EST UN PT DUAL ADMISSIBLE 69 : * 70 : JG=MLREE4.PROG(/1) 71 : SEGINI MLREEL,MLREE1 72 : DO 41 J=1,N11 73 : PROG(J)=1.D0/MLREE4.PROG(J) 74 : MLREE1.PROG(J)=1.D0/MLREE5.PROG(J) 75 : 41 CONTINUE 76 : MXMA2=MCP 77 : MXMA3=MCQ 77 : CALL MATVE1(MXMA2.XMAT,PROG,M,N11,MLREE6.PROG,2) 77 : CALL MATVE1(MXMA3.XMAT,MLREE1.PROG,M,N11,MLREE7.PROG,2) 78 : MLREE8=IVB 79 : NORMP=0.D0 80 : DO 42 J=1,M 81 : DIF=MLREE6.PROG(J)+MLREE7.PROG(J)-MLREE8.PROG(J) 82 : IF(DIF.GT.0.D0)THEN 83 : IF(UNAD) GO TO 2 84 : ADMI=.FALSE. 85 : NORMP=NORMP+(DIF**2) 86 : ENDIF 87 : 42 CONTINUE 88 : * 89 : * CALCUL DE LA VALEUR DE LA FONCTION PRIMALE VFP DE X 90 : * 91 : IF(ADMI) THEN 92 : IF(IIMPI.EQ.1799) 93 : *WRITE(IOIMP,FMT='( '' POINT ADMISSIBLE '' )') 94 : MLREE6=IVFP 95 : MLREE7=IVFQ 96 : SEGACT MLREE6,MLREE7 97 : VFP=0. 98 : DO 5 J = 1,N11 99 : VFP=VFP+(PROG(J)*MLREE6.PROG(J))+ 100 : * (MLREE1.PROG(J)*MLREE7.PROG(J)) 101 : 5 CONTINUE 102 : UNAD=.TRUE. 103 : * 104 : * RECHERCHE DU MIN DE VFP POUR LES PTS ADMISSIBLES 105 : * 106 : IF(VFP.LT.VFPMIN) THEN 107 : VFPMIN=VFP 108 : DO 20 J=1,N11 109 : MLREE2.PROG(J)=MLREE4.PROG(J) 110 : MLREE3.PROG(J)=MLREE5.PROG(J) 111 : 20 CONTINUE 112 : ENDIF 113 : ENDIF 114 : * 115 : * RECHERCHE DU PT QUI RESPECTE AU MIEUX LES CONTRAINTES SI PAS DE SOL 116 : * 117 : IF(.NOT.UNAD)THEN 118 : IF(NORMP.LT.NORMPM) THEN 119 : NORMPM=NORMP 120 : DO 21 J=1,N11 121 : MLREE2.PROG(J)=MLREE4.PROG(J) 122 : MLREE3.PROG(J)=MLREE5.PROG(J) 123 : 21 CONTINUE 124 : ENDIF 125 : ENDIF 126 : 2 CONTINUE 127 : IF(.NOT.UNAD) THEN 128 : IF(IIMPI.EQ.1799) 129 : *WRITE(IOIMP,FMT='( '' PAS DE POINT ADMISSIBLE '' )') 130 : ENDIF 131 : MLREEL=IBBU 132 : MLREE1=IBBL 133 : MLREE2=IBU 134 : MLREE3=IBL 135 : SEGACT MLREEL,MLREE1,MLREE2,MLREE3 136 : DO 30 I=1,N11 137 : MLREE2.PROG(I)=PROG(I) 138 : MLREE3.PROG(I)=MLREE1.PROG(I) 139 : 30 CONTINUE 140 : IF(IIMPI.EQ.1799) WRITE(IOIMP,FMT='('' VALEURS DE X DANS ETAP21 141 : * = IBU :'',/,(1X,5E12.5))')(MLREE2.PROG(I),I=1,N11) 142 : IF(IIMPI.EQ.1799) WRITE(IOIMP,FMT='('' VALEURS DE X DANS ETAP21 143 : * = IBL :'',/,(1X,5E12.5))')(MLREE3.PROG(I),I=1,N11) 144 : RETURN 145 : END 146 : 147 : 148 : 149 :
© Cast3M 2003 - All rights reserved.
Disclaimer