1 : C XTX3 SOURCE CHAT 05/01/13 04:15:34 5004 2 : SUBROUTINE XTX3(ICH1,ICH2,FLO1,FLO2,XDRET,IRET) 3 : C======================================================================= 4 : C ENTREES 5 : C ICH1 POINTEUR SUR UN CHPOINT 6 : C ICH2 POINTEUR SUR UN CHPOINT 7 : C FLO1 FLOTTANT 8 : C FLO2 FLOTTANT 9 : C SORTIES 10 : C XDRET = XTX FLO1 * ICH1 + FLO2 * FLO2 11 : C IRET = 1 SI SUCCES 0 SINON 12 : C======================================================================= 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8(A-H,O-Z) 15 : PARAMETER(XZER=0.D0) 16 : -INC CCOPTIO 17 : -INC SMCHPOI 18 : DIMENSION ITR(40) 19 : C 20 : XDRET=XZER 21 : IRET=1 22 : C 23 : MCHPO1=ICH1 24 : MCHPO2=ICH2 25 : C 26 : SEGACT MCHPO1,MCHPO2 27 : NS1=MCHPO1.IPCHP(/1) 28 : NS2=MCHPO2.IPCHP(/1) 29 : MOTERR(1:8)=MCHPO1.MTYPOI 30 : MOTERR(9:16)=MCHPO2.MTYPOI 31 : C 32 : C LES CHPOINTS SONT ILS COMPATIBLES ?? 33 : C 34 : IF(MCHPO1.IFOPOI.NE.MCHPO2.IFOPOI) GOTO 166 35 : IF(NS1.NE.NS2) GOTO 166 36 : C 37 : GOTO 20 38 : C 39 : C GESTION DE L ERREUR 40 : C 41 : 166 CONTINUE 42 : IRET=0 42 : CALL ERREUR(347) 43 : GOTO 666 44 : 20 CONTINUE 45 : C 46 : C QUELLES CORESPONDANCE ENTRE LES SOUS PAQUETS DES CHPOINTS 47 : C 48 : DO 100 IA=1,NS1 49 : MSOUP1=MCHPO1.IPCHP(IA) 50 : SEGACT MSOUP1 51 : IGEO1=MSOUP1.IGEOC 52 : SEGDES MSOUP1 53 : DO 110 IB=1,NS2 54 : MSOUP2=MCHPO2.IPCHP(IB) 55 : SEGACT MSOUP2 56 : IGEO2=MSOUP2.IGEOC 57 : IBB =MSOUP2.IPOVAL 58 : SEGDES MSOUP2 59 : IF(IGEO1.EQ.IGEO2) GOTO 120 60 : 110 CONTINUE 61 : C 62 : C MESSAGE D ERREUR 63 : C 64 : IRET=0 64 : CALL ERREUR(348) 65 : GOTO 666 66 : 120 CONTINUE 67 : ITR(IA)=IBB 68 : 100 CONTINUE 69 : C 70 : C BOUCLE SUR LES SOUS PAQUETS EN COMMUN 71 : C 72 : DO 200 IA=1,NS1 73 : MSOUP1=MCHPO1.IPCHP(IA) 74 : SEGACT MSOUP1 75 : MPOVA1=MSOUP1.IPOVAL 76 : SEGDES MSOUP1 77 : IBB=ITR(IA) 78 : MPOVA2= IBB 79 : C 80 : SEGACT MPOVA1,MPOVA2 81 : N1 =MPOVA1.VPOCHA(/1) 82 : NC1 =MPOVA1.VPOCHA(/2) 83 : N2 =MPOVA2.VPOCHA(/1) 84 : NC2 =MPOVA2.VPOCHA(/2) 85 : C 86 : C VERIFICATION TAILLE DES CHPOINTS 87 : C 88 : IF(N1.NE.N2) GOTO 444 89 : IF(NC1.NE.NC2) GOTO 444 90 : GOTO 330 91 : C 92 : C ERREUR TAILLE CHPOINTS 93 : C 94 : 444 CONTINUE 95 : MOTERR(1:8)='XTX3' 96 : IRET=0 96 : CALL ERREUR(178) 97 : SEGDES MPOVA1,MPOVA2 98 : GOTO 666 99 : C 100 : 330 CONTINUE 101 : DO 300 IB=1,N1 102 : DO 400 IC=1,NC1 103 : XXT1=MPOVA1.VPOCHA(IB,IC) 104 : XXT2=MPOVA2.VPOCHA(IB,IC) 105 : XX = FLO1*XXT1+FLO2*FLO2 106 : XDRET = XDRET + XX*XX 107 : 400 CONTINUE 108 : 300 CONTINUE 109 : SEGDES MPOVA1,MPOVA2 110 : 200 CONTINUE 111 : C 112 : 666 CONTINUE 113 : SEGDES MCHPO1,MCHPO2 114 : RETURN 115 : END 116 :
© Cast3M 2003 - All rights reserved.
Disclaimer