1 : C VARIPO SOURCE CHAT 05/01/13 04:04:04 5004 2 : SUBROUTINE VARIPO(IPOI1,IPOI2,MOT2,IPOI3) 3 : C---------------------------------------------------------------- 4 : C CHPOINT VARIABLE 5 : C---------------------------------------------------------------- 6 : C ENTREES: 7 : C IPOI1=POINTEUR SUR UN CHPOINT 8 : C IPOI2=POINTEUR SUR UN EVOLUTIO 9 : C MOT2 =NOM DE COMPOSANTE A DONNER AU RESULTAT 10 : C SORTIE: 11 : C IPOI3=POINTEUR SUR LE CHPOINT RESULTAT 12 : C---------------------------------------------------------------- 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8(A-H,O-Z) 15 : -INC CCOPTIO 16 : -INC SMEVOLL 17 : -INC SMCHPOI 18 : -INC SMLREEL 19 : -INC SMELEME 20 : CHARACTER*4 MOTREF,MOT1,MOT2,MOTABS,MOTORD 21 : SEGMENT/MTRA/(XVAL(0)*D) 22 : SEGMENT/MTRI/(IPOI(0)) 23 : SEGMENT/MTRAX/(XX(0)*D) 24 : SEGMENT/MTRAY/(YY(0)*D) 25 : DATA XZER,UN/0.D0,1.D0/ 26 : KERRE=0 27 : IPOI3=0 28 : C 29 : C ON RECUPERE L'OBJET EVOLUTION 30 : C 31 : MEVOLL=IPOI2 32 : SEGACT MEVOLL 33 : KEVOLL=IEVOLL(1) 34 : SEGACT KEVOLL 35 : MLREEL=IPROGX 36 : MLREE1=IPROGY 37 : MOTABS=NOMEVX(1:4) 38 : MOTORD=NOMEVY(1:4) 39 : SEGDES KEVOLL 40 : SEGACT MLREEL,MLREE1 41 : NBPOIX=PROG(/1) 42 : NBPOIY=MLREE1.PROG(/1) 43 : IF(NBPOIX.NE.NBPOIY) THEN 43 : CALL ERREUR(263) 44 : SEGDES MLREEL,MLREE1 45 : SEGDES MEVOLL 46 : RETURN 47 : ENDIF 48 : C 49 : SEGINI MTRAX 50 : SEGINI MTRAY 51 : DO 695 I=1,NBPOIX 52 : XX(**)=PROG(I) 53 : 695 CONTINUE 54 : DO 696 I=1,NBPOIY 55 : YY(**)=MLREE1.PROG(I) 56 : 696 CONTINUE 57 : SEGDES MLREEL,MLREE1 58 : SEGDES MEVOLL 59 : C 60 : C ON RECUPERE LE CHPOINT 61 : C 62 : MCHPO1=IPOI1 63 : SEGACT MCHPO1 64 : NSOUP1=MCHPO1.IPCHP(/1) 65 : C 66 : C RECHERCHE DU NOMBRE DE COMPOSANTES 67 : C 68 : DO 300 IA=1,NSOUP1 69 : MSOUP1=MCHPO1.IPCHP(IA) 70 : SEGACT MSOUP1 71 : NC1=MSOUP1.NOCOMP(/2) 72 : IF(NC1.EQ.1) GO TO 321 73 : 325 SEGDES MSOUP1 74 : MOTREF=MOTABS 75 : GO TO 320 76 : 321 IF(IA.EQ.1) THEN 77 : MOTREF=MSOUP1.NOCOMP(1) 78 : GO TO 330 79 : ENDIF 80 : IF(MOTREF.NE.MSOUP1.NOCOMP(1)) GOTO 325 81 : 330 SEGDES MSOUP1 82 : 300 CONTINUE 83 : C 84 : C BOUCLE SUR LES SOUS PAQUETS 85 : C 86 : 320 SEGINI MTRA,MTRI 87 : DO 100 IA=1,NSOUP1 88 : MSOUP1=MCHPO1.IPCHP(IA) 89 : SEGACT MSOUP1 90 : NC1=MSOUP1.NOCOMP(/2) 91 : DO 110 IB=1,NC1 92 : MOT1=MSOUP1.NOCOMP(IB) 93 : IF(MOT1.NE.MOTREF) GOTO 110 94 : IBVAL=IB 95 : GOTO 120 96 : 110 CONTINUE 97 : GOTO 130 98 : C 99 : 120 CONTINUE 100 : MOT1=MSOUP1.NOCOMP(IBVAL) 101 : MELEME=MSOUP1.IGEOC 102 : MPOVA1=MSOUP1.IPOVAL 103 : SEGACT MELEME,MPOVA1 104 : NBNN =NUM(/1) 105 : NBELEM=NUM(/2) 106 : N =MPOVA1.VPOCHA(/1) 107 : NC =MPOVA1.VPOCHA(/2) 108 : IF(N.EQ.NBELEM.AND.NBNN.EQ.1.AND.NC1.EQ.NC) GOTO 150 109 : C 110 : C ERREUR DANS LES DIMENSIONS DES CHPOINT 111 : C 112 : MOTERR(1:8)='VARIPO' 112 : CALL ERREUR(178) 113 : SEGDES MELEME,MPOVA1,MSOUP1 114 : GOTO 666 115 : C 116 : 150 CONTINUE 117 : DO 140 IC=1,NBELEM 118 : MM=NUM(1,IC) 119 : XVAL(**)=MPOVA1.VPOCHA(IC,IBVAL) 120 : IPOI(**)=MM 121 : 140 CONTINUE 122 : SEGDES MELEME,MPOVA1 123 : 130 CONTINUE 124 : SEGDES MSOUP1 125 : 100 CONTINUE 126 : C 127 : LX=XVAL(/1) 128 : C 129 : C ERREUR SI PAS DE COMPOSANTE DU TYPE RECHERCHE DANS MCHPOI 130 : C 131 : IF(LX.EQ.0) THEN 132 : MOTERR(1:4)=MOTABS 132 : CALL ERREUR(181) 133 : GOTO 666 134 : ENDIF 135 : C 136 : C ON REMPLIT LE NOUVEAU CHPOINT 137 : C 138 : IF(MOT2.EQ.' ') MOT2=MOTORD 139 : NSOUPO=1 140 : NAT=MCHPO1.JATTRI(/1) 141 : SEGINI MCHPOI 142 : MTYPOI='SCALAIRE' 143 : DO 160 II=1,NAT 144 : JATTRI(II)=MCHPO1.JATTRI(II) 145 : 160 CONTINUE 146 : NC=1 147 : SEGINI MSOUPO 148 : IPCHP(1)=MSOUPO 149 : NOCOMP(1)=MOT2 150 : NBNN =1 151 : NBELEM=LX 152 : NBSOUS=0 153 : NBREF =0 154 : SEGINI MELEME 155 : IGEOC=MELEME 156 : ITYPEL=1 157 : N =LX 158 : NC =1 159 : SEGINI MPOVAL 160 : IPOVAL=MPOVAL 161 : SEGDES MCHPOI,MSOUPO 162 : DO 220 IA=1,LX 163 : NUM(1,IA) =IPOI(IA) 164 : XTT1 =XVAL(IA) 164 : CALL VARIFO(XX,YY,NBPOIX,XTT1,YTT1,KERRE) 165 : IF(KERRE.NE.0) THEN 166 : SEGSUP MSOUPO,MCHPOI,MELEME,MPOVAL 166 : CALL ERREUR(KERRE) 167 : GOTO 666 168 : ENDIF 169 : VPOCHA(IA,1)=YTT1 170 : 220 CONTINUE 171 : IPOI3=MCHPOI 172 : SEGDES MELEME,MPOVAL 173 : C 174 : 666 CONTINUE 175 : SEGSUP MTRA,MTRI 176 : SEGSUP MTRAX,MTRAY 177 : SEGDES MCHPO1 178 : RETURN 179 : END 180 :
© Cast3M 2003 - All rights reserved.
Disclaimer