1 : C VARCHP SOURCE CHAT 05/01/13 04:01:36 5004 2 : SUBROUTINE VARCHP(IPOI1,IPOI2,IPOI3,IRET) 3 : C---------------------------------------------------------------- 4 : C ENTREES: 5 : C IPOI1=POINTEUR SUR UN CHPOINT 6 : C IPOI2=POINTEUR SUR UN EVOLUTION 7 : C SORTIE: 8 : C IPOI3=POINTEUR SUR LE CHPOINT RESULTAT 9 : C IRET = 1 SI SUCCES 0 SINON 10 : C---------------------------------------------------------------- 11 : IMPLICIT INTEGER(I-N) 12 : IMPLICIT REAL*8(A-H,O-Z) 13 : PARAMETER(XZER=0.D0) 14 : -INC CCOPTIO 15 : -INC SMEVOLL 16 : -INC SMCHPOI 17 : -INC SMLREEL 18 : C 19 : IRET =1 20 : KERRE=0 21 : YTT1=XZER 22 : C 23 : C ON RECUPERE L'OBJET EVOLUTION 24 : C 25 : MEVOLL=IPOI2 26 : SEGACT MEVOLL 27 : KEVOLL=IEVOLL(1) 28 : SEGACT KEVOLL 29 : MLREEL=IPROGX 30 : MLREE1=IPROGY 31 : SEGDES KEVOLL,MEVOLL 32 : SEGACT MLREEL,MLREE1 33 : NBPOIX=PROG(/1) 34 : NBPOIY=MLREE1.PROG(/1) 35 : C 36 : C ON RECUPERE LE CHPOINT 37 : C 38 : MCHPO1=IPOI1 39 : SEGACT MCHPO1 40 : NSOUPO=MCHPO1.IPCHP(/1) 41 : NAT=MCHPO1.JATTRI(/1) 42 : SEGINI MCHPOI 43 : IPOI3=MCHPOI 44 : IFOPOI =MCHPO1.IFOPOI 45 : MTYPOI=MCHPO1.MTYPOI 46 : MOCHDE=MCHPO1.MOCHDE 47 : C on attribue la meme nature 48 : DO 50 INAT=1,NAT 49 : JATTRI(INAT)=MCHPO1.JATTRI(1) 50 : 50 CONTINUE 51 : C 52 : C BOUCLE SUR LES SOUS PAQUETS 53 : C 54 : DO 100 IA=1,NSOUPO 55 : MSOUP1=MCHPO1.IPCHP(IA) 56 : SEGACT MSOUP1 57 : NC =MSOUP1.NOCOMP(/2) 58 : SEGINI MSOUPO 59 : IPCHP(IA)=MSOUPO 60 : IGEOC=MSOUP1.IGEOC 61 : DO 110 IB=1,NC 62 : NOCOMP(IB)=MSOUP1.NOCOMP(IB) 63 : NOHARM(IB)=MSOUP1.NOHARM(IB) 64 : 110 CONTINUE 65 : C 66 : MPOVA1=MSOUP1.IPOVAL 67 : SEGACT MPOVA1 68 : N =MPOVA1.VPOCHA(/1) 69 : SEGINI MPOVAL 70 : IPOVAL =MPOVAL 71 : DO 200 IB=1,N 72 : DO 200 IC=1,NC 73 : XTT1=MPOVA1.VPOCHA(IB,IC) 73 : CALL VARIFO(MLREEL.PROG,MLREE1.PROG,NBPOIX,XTT1,YTT1,KERRE) 74 : IF(KERRE.EQ.211) IRET=0 75 : VPOCHA(IB,IC)=YTT1 76 : 200 CONTINUE 77 : SEGDES MPOVA1,MPOVAL,MSOUPO,MSOUP1 78 : 100 CONTINUE 79 : SEGDES MCHPOI,MCHPO1 80 : SEGDES MLREEL,MLREE1 80 : IF(IRET.EQ.0) CALL DECHPO(IPOI3) 80 : IF(IRET.EQ.0) CALL ERREUR(KERRE) 81 : C 82 : RETURN 83 : END 84 :
© Cast3M 2003 - All rights reserved.
Disclaimer