1 : C MANUEL SOURCE GOUNAND 14/01/31 21:15:08 7926 2 : SUBROUTINE MANUEL 3 : C 4 : C FABRICATION MANUELLE D OBJETS DIVERS ET VARIES 5 : C DE TYPE ELEMENT,CHAMPOIN,SOLUTION, RIGIDITE, CHAMELEM ,EVOLUTION 6 : C 7 : IMPLICIT INTEGER(I-N) 8 : -INC CCOPTIO 9 : -INC CCGEOME 10 : -INC SMELEME 11 : SEGMENT MTRT 12 : INTEGER MTT(NTT) 13 : ENDSEGMENT 14 : PARAMETER (LMOOPT=7) 15 : CHARACTER*4 MOOPT(LMOOPT) 16 : DATA MOOPT/'CHPO','MODE','RIGI','CHEL','CHAM','CHML','OBJE'/ 16 : CALL LIRMOT(NOMS,NOMBR,I,0) 17 : IF (I.NE.0) GOTO 2 17 : CALL LIRMOT(MOOPT,LMOOPT,IMOT,1) 18 : IF(IERR.NE.0) RETURN 19 : GO TO (100,200,300,400,500,600,700),IMOT 19 : 100 CALL MANUCH 20 : GO TO 30 20 : 200 CALL MANUMO 21 : GO TO 30 21 : 300 CALL MANURI 22 : GO TO 30 22 : 400 CALL MANUCE 23 : GO TO 30 23 : 500 CALL MAMANU 24 : GO TO 30 24 : 600 CALL MANUC5 25 : GO TO 30 25 : 700 CALL MANUOB 26 : GO TO 30 27 : c 28 : c==== Cas des Objets MAILLAGES ==================================== 29 : 2 ITYP=I 29 : CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) 30 : IF (ICOUL.EQ.0) ICOUL=IDCOUL+1 31 : ICOUL=ICOUL-1 32 : NBSOUS=0 33 : NBREF=0 34 : NBELEM=1 35 : c---- SUPERELEMENT --------------- 36 : IF(NOMS(ITYP).EQ.'SUPE') THEN 36 : CALL LIROBJ('MAILLAGE',IPT1,0,IRETOU) 37 : IF(IRETOU.EQ.0) GO TO 25 38 : SEGACT IPT1 39 : IF(IPT1.ITYPEL.NE.1) THEN 39 : CALL CHANGE ( IPT1,1) 40 : IF (IERR.NE.0) RETURN 41 : SEGACT IPT1 42 : ENDIF 43 : NBNN = IPT1.NUM(/2) 44 : SEGINI MELEME 45 : ICOLOR(1)=ICOUL 46 : ITYPEL=ITYP 47 : DO 26 I=1,NBNN 48 : NUM(I,1)=IPT1.NUM(1,I) 49 : 26 CONTINUE 50 : GO TO 11 51 : 25 NTT=50 52 : SEGINI MTRT 53 : NBNN=0 54 : 28 CONTINUE 54 : CALL LIROBJ('POINT ',IP,0,IRETOU) 55 : IF(IRETOU.EQ.0)GO TO 29 56 : NBNN=NBNN + 1 57 : IF(NBNN.GT.NTT) THEN 58 : NTT=NTT+50 59 : SEGADJ MTRT 60 : ENDIF 61 : MTT(NBNN) = IP 62 : GO TO 28 63 : 29 CONTINUE 64 : SEGINI MELEME 65 : ICOLOR(1)=ICOUL 66 : ITYPEL=ITYP 67 : DO 27 I=1,NBNN 68 : NUM(I,1)=MTT(I) 69 : 27 CONTINUE 70 : SEGSUP MTRT 71 : c---- AUTRE TYPE D'ELEMENTS --------------- 72 : ELSE 73 : NBNN=NBNNE(ITYP) 74 : c dans le cas POLYgone et MULtiplicateur le nbre de noeuds par 75 : c element est indefini d'ou la lecture facultative des points 76 : IF (NOMS(ITYP).EQ.'POLY') THEN 77 : NBNN = 14 78 : IDOBL = 0 79 : ELSE IF (NOMS(ITYP).EQ.'MULT') THEN 80 : NBNN = 9999 81 : IDOBL = 0 82 : ELSE 83 : IDOBL = 1 84 : ENDIF 85 : SEGINI MELEME 86 : ICOLOR(1)=ICOUL 87 : ITYPEL=ITYP 88 : C SG On ajoute la possibilité de générer un élément à partir 89 : C des premiers points d'un maillage de 'POI1' 89 : CALL LIROBJ('MAILLAGE',IPT1,0,IRETOU) 90 : IF (IRETOU.NE.0) THEN 91 : SEGACT IPT1 92 : IF(IPT1.ITYPEL.NE.1) THEN 92 : CALL CHANGE ( IPT1,1) 93 : IF (IERR.NE.0) RETURN 94 : SEGACT IPT1 95 : ENDIF 96 : NBNN1=IPT1.NUM(/2) 97 : IF (NBNN1.EQ.0) THEN 98 : NBELEM=0 99 : SEGADJ MELEME 100 : GOTO 11 101 : ENDIF 102 : IF (IDOBL.EQ.0) NBNN=NBNN1 103 : SEGINI MELEME 104 : ICOLOR(1)=ICOUL 105 : ITYPEL=ITYP 106 : DO 260 I=1,NBNN 107 : NUM(I,1)=IPT1.NUM(1,(MOD(I-1,NBNN1))+1) 108 : 260 CONTINUE 109 : ELSE 110 : DO 10 I=1,NBNN 110 : c CALL LIROBJ('POINT ',IP,IDOBL,IRETOU) 111 : c on donne ici la possibilité de créer un meleme avec 0 élément 112 : IF(I.EQ.1) THEN 112 : CALL LIROBJ('POINT ',IP,0,IRETOU) 113 : ELSE 113 : CALL LIROBJ('POINT ',IP,IDOBL,IRETOU) 114 : ENDIF 115 : IF (IRETOU.NE.1) THEN 116 : IF (I.EQ.1) THEN 117 : NBELEM = 0 118 : SEGADJ MELEME 119 : if(iimpi.ge.1) write(ioimp,* 120 : $ )'MAILLAGE DE 0 ELEMENT CREE' 121 : ENDIF 122 : IF (IDOBL.EQ.0) THEN 123 : C CAS DU POLYGONE ou du MULT 124 : NBNN = I-1 125 : SEGADJ MELEME 126 : ENDIF 127 : GOTO 11 128 : ENDIF 129 : NUM(I,1)=IP 130 : 10 CONTINUE 131 : ENDIF 132 : ENDIF 133 : 11 CONTINUE 134 : IF (IERR.NE.0) GOTO 20 134 : CALL ECROBJ('MAILLAGE',MELEME) 135 : SEGDES MELEME 136 : RETURN 137 : 20 SEGSUP MELEME 138 : 30 CONTINUE 139 : RETURN 140 : END 141 : 142 : 143 : 144 : 145 :
© Cast3M 2003 - All rights reserved.
Disclaimer