1 : C XTX4 SOURCE PV 09/03/12 21:37:31 6325 2 : SUBROUTINE XTX4(IPCHE1,IPCHE2,FLO1,FLO2,XDRET,IRET) 3 : *_______________________________________________________________________ 4 : * 5 : * OPERATEUR XTX 6 : * 7 : * ENTREES : 8 : * --------- 9 : * IPCHE1 POINTEUR SUR UN CHAMELEM 10 : * IPCHE2 POINTEUR SUR UN CHAMELEM 11 : * FLO1 FLOTTANT 12 : * FLO2 FLOTTANT 13 : * 14 : * 15 : * SORTIES : 16 : * --------- 17 : * XDRET XTX = FLO1 * ICH1 + FLO2 * FLO2 18 : * IRET 1 SI SUCCES 0 SINON 19 : * 20 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 02/91 21 : * 22 : *_______________________________________________________________________ 23 : * 24 : IMPLICIT INTEGER(I-N) 25 : IMPLICIT REAL*8(A-H,O-Z) 26 : * 27 : -INC CCOPTIO 28 : -INC SMELEME 29 : -INC SMCHAML 30 : -INC SMINTE 31 : -INC SMLREEL 32 : * 33 : C CHARACTER*8 MOT1,MOT3 34 : CHARACTER*16 CONCH1,CONCH2 35 : PARAMETER(XZER=0.D0) 36 : DIMENSION ITR(40) 37 : PARAMETER(NINF=3) 38 : DIMENSION INFOS(NINF) 39 : * 40 : XDRET=XZER 41 : IRET=1 42 : * 43 : MCHEL1=IPCHE1 44 : MCHEL2=IPCHE2 45 : * 46 : SEGACT MCHEL1,MCHEL2 47 : * 48 : * LES CHAMELEMS SONT ILS COMPATIBLES ?? 49 : * 50 : NSOUS1=MCHEL1.ICHAML(/1) 51 : NSOUS2=MCHEL2.ICHAML(/1) 52 : IF (NSOUS1.NE.NSOUS2) GOTO 166 53 : * 54 : IFO1=MCHEL1.IFOCHE 55 : IFO2=MCHEL2.IFOCHE 56 : IF (IFO1.NE.IFO2) GOTO 166 57 : * 58 : GOTO 20 59 : * 60 : * GESTION DE L ERREUR 61 : * 62 : 166 CONTINUE 63 : C MOTERR(1:16)=MOT1//MOT3 63 : CALL ERREUR(329) 64 : GOTO 666 65 : * 66 : 20 CONTINUE 67 : N31=MCHEL1.INFCHE(/2) 68 : N32=MCHEL2.INFCHE(/2) 69 : N33=MAX(N31,N32) 70 : * 71 : DO 100 ISOUS=1,NSOUS1 72 : IPMAI1=MCHEL1.IMACHE(ISOUS) 73 : CONCH1=MCHEL1.CONCHE(ISOUS) 74 : DO 110 ISOUS2=1,NSOUS2 75 : IBB=ISOUS2 76 : IPMAI2=MCHEL2.IMACHE(ISOUS2) 77 : CONCH2=MCHEL2.CONCHE(ISOUS2) 78 : IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN 79 : * 80 : * Verification pour les INFCHEs 81 : * 81 : CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) 82 : IF (IRTD.EQ.0) GOTO 166 83 : DO 21 IN3=1,N33 84 : IF (IN3.GT.N31) THEN 85 : INF1=0 86 : ELSE 87 : INF1=MCHEL1.INFCHE(ISOUS,IN3) 88 : ENDIF 89 : IF (IN3.GT.N32) THEN 90 : INF2=0 91 : ELSE 92 : INF2=MCHEL2.INFCHE(IBB ,IN3) 93 : ENDIF 94 : IF (IN3.EQ.4) THEN 95 : IF (INF1.EQ.INF2) GOTO 21 96 : IF (N31.GE.6) INF1=MCHEL1.INFCHE(ISOUS,6) 97 : IF (N32.GE.6) INF2=MCHEL2.INFCHE(IBB ,6) 98 : IF (INF1.EQ.0) INF1=1 99 : IF (INF2.EQ.0) INF1=1 100 : IF (INF1.EQ.INF2) GOTO 21 101 : GOTO 166 102 : ELSE IF (IN3.EQ.6) THEN 103 : IF (INF1.EQ.0) INF1=1 104 : IF (INF2.EQ.0) INF1=1 105 : IF (INF1.EQ.INF2) GOTO 21 106 : GOTO 166 107 : ELSE 108 : IF (INF1.EQ.INF2) GOTO 21 109 : GOTO 166 110 : ENDIF 111 : 21 CONTINUE 112 : GOTO 120 113 : ENDIF 114 : 110 CONTINUE 115 : GOTO 166 116 : * 117 : 120 CONTINUE 118 : * 119 : * ACTIVATION DU MELEME 120 : * 121 : MELEME=IPMAI1 122 : SEGACT MELEME 123 : NBELEM=NUM(/2) 124 : * 125 : MINTE=0 126 : IF (N31.GE.4) MINTE=MCHEL1.INFCHE(ISOUS,4) 127 : IF (MINTE.EQ.0.AND.N32.GE.4) MINTE=MCHEL2.INFCHE(ISOUS2,4) 128 : IF (MINTE.EQ.0) THEN 129 : NBPGAU=NUM(/1) 130 : ELSE 131 : SEGACT MINTE 132 : NBPGAU=POIGAU(/1) 133 : SEGDES MINTE 134 : ENDIF 135 : SEGDES MELEME 136 : * 137 : MCHAM1=MCHEL1.ICHAML(ISOUS ) 138 : MCHAM2=MCHEL2.ICHAML(IBB ) 139 : SEGACT MCHAM1,MCHAM2 140 : * 141 : NCOMP1=MCHAM1.IELVAL(/1) 142 : NCOMP2=MCHAM2.IELVAL(/1) 143 : IF (NCOMP1.NE.NCOMP2) THEN 143 : CALL ERREUR (103) 144 : GOTO 667 145 : ENDIF 146 : * 147 : DO 150 ICOMP=1,NCOMP1 147 : CALL PLACE(MCHAM2.NOMCHE,NCOMP2,IPLAC,MCHAM1.NOMCHE(ICOMP)) 148 : IF (IPLAC.EQ.0) THEN 149 : MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP) 150 : MOTERR(5:8)=MCHEL1.TITCHE 150 : CALL ERREUR (77) 151 : GOTO 667 152 : ENDIF 153 : * 154 : MELVA1=MCHAM1.IELVAL(ICOMP) 155 : MELVA2=MCHAM2.IELVAL(IPLAC) 156 : SEGACT MELVA1,MELVA2 157 : IF ( MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8'.AND. 158 : & MCHAM2.TYPCHE(IPLAC).EQ.'REAL*8' ) THEN 159 : DO 300 IB=1,NBELEM 160 : IBMN1=MIN(IB,MELVA1.VELCHE(/2)) 161 : IBMN2=MIN(IB,MELVA2.VELCHE(/2)) 162 : DO 400 IGAU=1,NBPGAU 163 : IGMN1=MIN(IGAU,MELVA1.VELCHE(/1)) 164 : IGMN2=MIN(IGAU,MELVA2.VELCHE(/1)) 165 : XXT1=MELVA1.VELCHE(IGMN1,IBMN1) 166 : XXT2=MELVA2.VELCHE(IGMN2,IBMN2) 167 : XX = FLO1*XXT1 + FLO2*XXT2 168 : XDRET = XDRET + XX*XX 169 : 400 CONTINUE 170 : 300 CONTINUE 171 : ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL'.AND. 172 : & MCHAM2.TYPCHE(IPLAC).EQ.'POINTEURLISTREEL' ) THEN 173 : DO 301 IB=1,NBELEM 174 : IBMN1=MIN(IB,MELVA1.IELCHE(/2)) 175 : IBMN2=MIN(IB,MELVA2.IELCHE(/2)) 176 : DO 401 IGAU=1,NBPGAU 177 : IGMN1=MIN(IGAU,MELVA1.IELCHE(/1)) 178 : IGMN2=MIN(IGAU,MELVA2.IELCHE(/1)) 179 : MLREE1=MELVA1.IELCHE(IGMN1,IBMN1) 180 : MLREE2=MELVA2.IELCHE(IGMN2,IBMN2) 181 : SEGACT MLREE1,MLREE2 182 : JG1=MLREE1.PROG(/1) 183 : JG2=MLREE2.PROG(/1) 184 : IF (JG1.NE.JG2) THEN 185 : SEGDES MLREE1,MLREE2 186 : MOTERR(1:4)='XTX ' 187 : MOTERR(5:12)='MLREEL' 187 : CALL ERREUR (125) 188 : GOTO 668 189 : ENDIF 190 : DO 200 IPROG=1,JG1 191 : XXT1=MLREE1.PROG(IPROG) 192 : XXT2=MLREE2.PROG(IPROG) 193 : XX = FLO1*XXT1 + FLO2*FLO2 194 : XDRET = XDRET + XX*XX 195 : 200 CONTINUE 196 : SEGDES MLREE1,MLREE2 197 : 401 CONTINUE 198 : 301 CONTINUE 199 : ELSE 200 : MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP) 200 : CALL ERREUR (197) 201 : GOTO 668 202 : ENDIF 203 : SEGDES MELVA1,MELVA2 204 : 150 CONTINUE 205 : SEGDES MCHAM1,MCHAM2 206 : 100 CONTINUE 207 : SEGDES MCHEL1,MCHEL2 208 : RETURN 209 : * 210 : 668 CONTINUE 211 : SEGDES MELVA1,MELVA2 212 : * 213 : 667 CONTINUE 214 : SEGDES MCHAM1,MCHAM2 215 : * 216 : 666 CONTINUE 217 : SEGDES MCHEL1,MCHEL2 218 : IRET=0 219 : RETURN 220 : END 221 : 222 : 223 : 224 :
© Cast3M 2003 - All rights reserved.
Disclaimer