1 : C FENETR SOURCE CHAT 05/01/12 23:58:23 5004 2 : SUBROUTINE FENETR 3 : C ====================================================================== 4 : C FABRICATION D'UN OBJET EVOLUTION CONTENANT LES FONCTIONS 5 : C DE GREEN VUES A TRAVERS UNE FENETRE 6 : C 7 : C GREEN2 = FENE GREEN1 EVOLFE ; 8 : C 9 : C GREEN1: OBJET EVOLUTION CONTENANT LES FONCTIONS DE GREEN 10 : C EVOLFE: OBJET EVOLUTION CONTENANT LA FENETRE 11 : C GREEN2: OBJET EVOLUTION CONTENANT LES FONCTIONS DE GREEN VUES A 12 : C TRAVERS LA FENETRE 13 : C 14 : C PROGRAMMEUR : GUILBAUD 15 : C CREATION : 07/10/87 16 : C ====================================================================== 17 : C 18 : IMPLICIT INTEGER(I-N) 19 : IMPLICIT REAL*8(A-H,O-Z) 20 : -INC CCOPTIO 21 : -INC SMEVOLL 22 : -INC SMLREEL 23 : EPS=1.D-3 24 : C 25 : C 1 - LECTURES 26 : C 26 : CALL LIROBJ ('EVOLUTIO',IRETG,1,IRETOU) 27 : IF(IERR.NE.0) RETURN 27 : CALL LIROBJ ('EVOLUTIO',IRETF,1,IRETOU) 28 : IF(IERR.NE.0) RETURN 29 : C 30 : C 2 - VERIFICATIONS 31 : C 32 : MEVOLL=IRETG 33 : SEGACT MEVOLL 34 : N=IEVOLL(/1) 35 : WRITE(6,*) 'N= ',N 36 : KEVOLL=IEVOLL(1) 37 : SEGACT KEVOLL 38 : MEVOL1=IRETF 39 : SEGACT MEVOL1 40 : KEVOL1=MEVOL1.IEVOLL(1) 41 : SEGACT KEVOL1 42 : IPROG1=KEVOL1.IPROGX 43 : IF(IPROGX.NE.IPROG1) THEN 44 : MLREEL=IPROGX 45 : SEGACT MLREEL 46 : L=PROG(/1) 47 : MLREE1=IPROG1 48 : SEGACT MLREE1 49 : L1=MLREE1.PROG(/1) 49 : IF(L.EQ.L1) CALL VERIPR(PROG(1),MLREE1.PROG(1),L,IRETOU,EPS) 50 : SEGDES MLREEL 51 : SEGDES MLREE1 52 : IF(L.NE.L1.OR.IRETOU.EQ.0) THEN 53 : SEGDES MEVOLL 54 : SEGDES MEVOL1 55 : SEGDES KEVOLL 56 : SEGDES KEVOL1 57 : C *** LA FENETRE N'EST PAS APPLICABLE AUX FONCTIONS DE GREEN 57 : CALL ERREUR(393) 58 : RETURN 59 : ENDIF 60 : ENDIF 61 : MLREE1=KEVOL1.IPROGY 62 : SEGDES KEVOL1 63 : SEGDES MEVOL1 64 : SEGACT MLREE1 65 : C 66 : C 3 - CREATION 67 : C 68 : SEGINI MEVOL2 69 : MEVOL2.ITYEVO=ITYEVO 70 : DO 40 NN=1,N 71 : KEVOLL=IEVOLL(NN) 72 : SEGACT KEVOLL 73 : MLREEL=IPROGY 74 : SEGACT MLREEL 75 : JG=L 76 : SEGINI MLREE2 77 : SEGINI KEVOL2 78 : KEVOL2.TYPX='LISTREEL' 79 : KEVOL2.TYPY='LISTREEL' 80 : MEVOL2.IEVOLL(NN)=KEVOL2 81 : KEVOL2.NOMEVX=NOMEVX 82 : KEVOL2.NOMEVY=NOMEVY 83 : KEVOL2.NUMEVX=NUMEVX 84 : KEVOL2.NUMEVY=NUMEVY 85 : KEVOL2.KEVTEX=KEVTEX 86 : DO 30 LL=1,L 87 : MLREE2.PROG(LL)=PROG(LL)*MLREE1.PROG(LL) 88 : 30 CONTINUE 89 : KEVOL2.IPROGY=MLREE2 90 : KEVOL2.IPROGX=IPROGX 91 : SEGDES MLREEL 92 : SEGDES KEVOLL 93 : SEGDES MLREE2 94 : SEGDES KEVOL2 95 : 40 CONTINUE 96 : SEGDES MLREE1 97 : SEGDES MEVOL2 98 : C 99 : C 4 - ECRITURE 100 : C 101 : IRET2=MEVOL2 101 : CALL ECROBJ('EVOLUTIO',IRET2) 102 : RETURN 103 : END 104 :
© Cast3M 2003 - All rights reserved.
Disclaimer