1 : C XTX2 SOURCE PV 09/03/12 21:37:30 6325 2 : SUBROUTINE XTX2(IPCHE1,XFLOT,IRET) 3 : *_______________________________________________________________________ 4 : * 5 : * OPERATEUR XTX 6 : * 7 : * ENTREE : 8 : * -------- 9 : * IPCHE1 POINTEUR SUR UN MCHAM 10 : * 11 : * 12 : * SORTIE : 13 : * -------- 14 : * XFLOT NORME DU CHAMELEM 15 : * IRET =1 OU 0 SUIVANT SUCCES OU PAS 16 : * 17 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 02/91 18 : * 19 : *_______________________________________________________________________ 20 : * 21 : IMPLICIT INTEGER(I-N) 22 : IMPLICIT REAL*8(A-H,O-Z) 23 : * 24 : -INC SMCHAML 25 : -INC CCOPTIO 26 : -INC SMELEME 27 : -INC SMINTE 28 : -INC SMLREEL 29 : * 30 : IRET=1 31 : MCHELM=IPCHE1 32 : SEGACT MCHELM 33 : NSOUS=ICHAML(/1) 34 : XFLOT=0.D0 35 : * 36 : * BOUCLE SUR LES SOUS REFERENCES 37 : * 38 : DO 100 ISOUS=1,NSOUS 39 : * 40 : * RECUPERATION DES CARACTERISTIQUES DU CHAMELEM 41 : * 42 : MELEME=IMACHE(ISOUS) 43 : SEGACT MELEME 44 : NBELEM=NUM(/2) 45 : * 46 : MINTE=0 47 : IF (INFCHE(/2).GE.4) MINTE=INFCHE(ISOUS,4) 48 : IF (MINTE.EQ.0) THEN 49 : NBPGAU=NUM(/1) 50 : ELSE 51 : SEGACT MINTE 52 : NBPGAU=POIGAU(/1) 53 : SEGDES MINTE 54 : ENDIF 55 : SEGDES MELEME 56 : * 57 : MCHAML=ICHAML(ISOUS) 58 : SEGACT MCHAML 59 : NCOMP=IELVAL(/1) 60 : * 61 : DO 110 ICOMP=1,NCOMP 62 : MELVAL=IELVAL(ICOMP) 63 : SEGACT MELVAL 64 : IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN 65 : DO 200 IGAU=1,NBPGAU 66 : IGMN=MIN(IGAU,VELCHE(/1)) 67 : DO 200 IB=1,NBELEM 68 : IBMN=MIN(IB,VELCHE(/2)) 69 : XX=VELCHE(IGMN,IBMN) 70 : XFLOT=XFLOT+XX*XX 71 : 200 CONTINUE 72 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN 73 : DO 201 IGAU=1,NBPGAU 74 : IGMN=MIN(IGAU,IELCHE(/1)) 75 : DO 201 IB=1,NBELEM 76 : IBMN=MIN(IB,IELCHE(/2)) 77 : MLREEL=IELCHE(IGMN,IBMN) 78 : SEGACT MLREEL 79 : DO 120 IPROG=1,PROG(/1) 80 : XX=PROG(IPROG) 81 : XFLOT=XFLOT+XX*XX 82 : 120 CONTINUE 83 : SEGDES MLREEL 84 : 201 CONTINUE 85 : ELSE 86 : MOTERR(1:4)=NOMCHE(ICOMP) 86 : CALL ERREUR (197) 87 : GOTO 666 88 : ENDIF 89 : SEGDES MELVAL 90 : 110 CONTINUE 91 : SEGDES MCHAML 92 : 100 CONTINUE 93 : SEGDES MCHELM 94 : RETURN 95 : * 96 : 666 CONTINUE 97 : SEGDES MELVAL 98 : SEGDES MCHAML 99 : SEGDES MCHELM 100 : IRET=0 101 : RETURN 102 : END 103 : 104 : 105 :
© Cast3M 2003 - All rights reserved.
Disclaimer