1 : C COPIER SOURCE FANDEUR 10/12/14 21:15:36 6812 2 : SUBROUTINE COPIER 3 : ************************************************************************ 4 : * 5 : * C O P I E R 6 : * ----------- 7 : * 8 : * SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "COPIER" 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * CREER UN 2-IEME OBJET IDENTIQUE A UN OBJET DONNE. 14 : * 15 : * PHRASE D'APPEL (EN GIBIANE): 16 : * ---------------------------- 17 : * 18 : * OBJ2 = COPIER OBJ1 ; 19 : * 20 : * OPERANDE ET RESULTAT: 21 : * --------------------- 22 : * 23 : * OBJ1 TYPE-1 OBJET DONT ON VEUT UNE COPIE. 24 : * OBJ2 TYPE-1 COPIE DE "OBJ1". 25 : * 26 : * TYPE-1 VAUT 'LISTCHPO' OU 'CHPOINT' OU 'LISTREEL' OU 'MCHAML' 27 : * (A COMPLETER AU FUR ET A MESURE) 28 : * 29 : * LEXIQUE: (ORDRE ALPHABETIQUE) 30 : * -------- 31 : * 32 : * MODE DE FONCTIONNEMENT: 33 : * ----------------------- 34 : * 35 : * APPEL D'UN SOUS-PROGRAMME DISTINCT SELON LE TYPE DE L'OBJET QUE 36 : * L'ON COPIE. 37 : * 38 : * SOUS-PROGRAMMES APPELES: 39 : * ------------------------ 40 : * 41 : * ECROBJ,COPIE1,COPIE2,COPIE3,COPIE4 42 : * 43 : * AUTEUR, DATE DE CREATION: 44 : * ------------------------- 45 : * 46 : * PASCAL MANIGOT 11 AVRIL 1985 47 : * 48 : * LANGAGE: 49 : * -------- 50 : * 51 : * FORTRAN77 + EXTENSION 52 : * 53 : ************************************************************************ 54 : * 55 : IMPLICIT INTEGER(I-N) 56 : IMPLICIT REAL*8(A-H,O-Z) 57 : -INC CCOPTIO 58 : -INC SMCHPOI 59 : -INC SMELEME 60 : -INC SMLREEL 61 : -INC SMTABLE 62 : CHARACTER*4 MOLIS(1) 63 : CHARACTER*8 MOTYPE 64 : DATA MOLIS/'GEOM'/ 64 : CALL LIRMOT(MOLIS,1,IRET,0) 65 : C PP 65 : CALL LIROBJ('TABLE',IPOIN1,0,IRETOU) 66 : IF(IRETOU.EQ.0) GO TO 10 67 : MOTYPE = 'TABLE' 68 : MTAB1=IPOIN1 69 : SEGINI,MTABLE=MTAB1 70 : SEGDES,MTABLE 71 : IPOIN2=MTABLE 72 : GO TO 900 73 : 10 CONTINUE 74 : C PP 74 : CALL LIROBJ('LISTCHPO',IPOIN1,0,IRETOU) 75 : IF(IRETOU.EQ.0) GO TO 20 76 : MOTYPE = 'LISTCHPO' 76 : CALL COPIE1 (IPOIN1,IPOIN2) 77 : GO TO 900 78 : C 79 : C COPIE DE CHPOINT 80 : C 81 : 20 CONTINUE 81 : CALL LIROBJ('CHPOINT',IPOIN1,0,IRETOU) 82 : IF(IRETOU.EQ.0) GO TO 30 83 : MOTYPE = 'CHPOINT' 83 : CALL COPIE2 (IPOIN1,IPOIN2) 84 : IF(IRET.NE.0) THEN 85 : MCHPOI=IPOIN2 86 : SEGACT MCHPOI 87 : DO 1 I=1,IPCHP(/1) 88 : MSOUPO=IPCHP(I) 89 : SEGACT MSOUPO*MOD 90 : IPT1=IGEOC 91 : SEGINI,MELEME=IPT1 92 : SEGDES MELEME 93 : IGEOC=MELEME 94 : SEGDES MSOUPO 95 : 1 CONTINUE 96 : ENDIF 97 : GO TO 900 98 : C 99 : C COPIE DE MCHAML 100 : C 101 : 30 CONTINUE 101 : CALL LIROBJ('MCHAML',IPOIN1,0,IRETOU) 102 : IF(IRETOU.EQ.0) GO TO 40 103 : MOTYPE = 'MCHAML' 103 : CALL COPIE8(IPOIN1,IPOIN2) 104 : GO TO 900 105 : C 106 : C COPIE DE LISTREEL 107 : C 108 : 40 CONTINUE 108 : CALL MESLIR(-148) 108 : CALL LIROBJ('LISTREEL',IPOIN1,1,IRETOU) 109 : MOTYPE = 'LISTREEL' 110 : IF(IERR.NE.0) RETURN 110 : CALL COPIE4(IPOIN1,IPOIN2) 111 : GO TO 900 112 : C 113 : 900 CONTINUE 113 : CALL ECROBJ (MOTYPE,IPOIN2) 114 : 115 : RETURN 116 : END 117 : 118 :
© Cast3M 2003 - All rights reserved.
Disclaimer