1 : C MOCR SOURCE GOUNAND 13/10/21 21:15:23 7822 2 : C MODI CREATION D'ELEMENT 3 : C 4 : SUBROUTINE MOCR(XPROJ,IVU,IDCP,MELEME,ICPR,ITE,IMILL,TMIN,IBOUJ) 5 : IMPLICIT INTEGER(I-N) 6 : COMMON/CMODI/LIGMAX,XDEC,YDEC 7 : -INC SMELEME 8 : -INC CCOPTIO 9 : -INC CCGEOME 10 : -INC SMCOORD 11 : DIMENSION XTR(10),YTR(10),ZTR(10) 12 : SEGMENT XPROJ(3,ITE) 13 : SEGMENT IVU(ITE) 14 : SEGMENT IDCP(ITE) 15 : SEGMENT ICPR(0) 16 : SEGMENT IMILL(ITE) 17 : SEGMENT IBOUJ(0) 18 : CHARACTER*4 LEGEND(11) 19 : CHARACTER*8 ZONE 20 : do i=1,10 21 : ztr(i)=0 22 : enddo 23 : XPR=XDEC**2 24 : TTEMP=TMIN 25 : 10 CONTINUE 25 : CALL TRMESS('Choisissez le type d''element') 26 : LEGEND(1)=' ' 27 : LEGEND(2)='POI1' 28 : LEGEND(3)='SEG2' 29 : LEGEND(4)='SEG3' 30 : LEGEND(5)='TRI3' 31 : LEGEND(6)=' ' 32 : LEGEND(7)='TRI6' 33 : LEGEND(8)=' ' 34 : LEGEND(9)='QUA4' 35 : LEGEND(10)=' ' 36 : LEGEND(11)='QUA8' 36 : CALL MENU(LEGEND,11,4) 36 : CALL TRAFF(ICLE) 37 : IF (ICLE.NE.2.AND.ICLE.NE.3.AND.ICLE.NE.4.AND.ICLE.NE.6 38 : # .AND.ICLE.NE.8.AND.ICLE.NE.10.AND.ICLE.NE.1) THEN 39 : GOTO 10 40 : ENDIF 41 : IF (KDEGRE(ICLE).EQ.3) THEN 42 : * IL FAUT INDIQUER OU SONT LES POINTS MILIEUX 42 : call insegt(3,iresu) 42 : CALL CHCOUL(IDNOIR) 43 : IPT1=MELEME 44 : DO 30 IO=1,MAX(1,LISOUS(/1)) 45 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO) 46 : IF (KDEGRE(IPT1.ITYPEL).NE.3) GOTO 40 47 : DO 50 I=1,IPT1.NUM(/1) 48 : DO 50 J=1,IPT1.NUM(/2) 49 : IP=ICPR(IPT1.NUM(I,J)) 50 : IF (IMILL(IP).NE.0) GOTO 50 51 : XTR(1)=XPROJ(1,IP) 52 : YTR(1)=XPROJ(2,IP) 53 : XTR(2)=XPROJ(1,IP) 54 : YTR(2)=XPROJ(2,IP) 54 : CALL POLRL(2,XTR,YTR,ZTR) 55 : IMILL(IP)=1 56 : 50 CONTINUE 57 : 40 CONTINUE 58 : 30 CONTINUE 59 : ENDIF 60 : NBELEM=0 61 : NBSOUS=0 62 : NBREF=0 63 : NBNN=NBNNE(ICLE) 64 : SEGINI IPT8 65 : IPT8.ITYPEL=ICLE 66 : 100 CONTINUE 66 : CALL TRMESS('Pointez les points de l''element') 67 : NBELEM=NBELEM+1 68 : SEGADJ IPT8 68 : CALL CHCOUL(5) 69 : DO 110 I=1,NBNN 69 : CALL TRDIG(X,Y,INCLE) 70 : IF (INCLE.EQ.3) GOTO 141 71 : DO 120 IP=1,ITE 72 : IF (IVU(IP).NE.1) GOTO 120 73 : IF((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LT.XPR) GOTO 130 74 : 120 CONTINUE 75 : ITE=ITE+1 76 : SEGADJ XPROJ 77 : XPROJ(1,ITE)=X 78 : XPROJ(2,ITE)=Y 79 : XPROJ(3,ITE)=TTEMP 80 : XCOOR(**)=X 81 : XCOOR(**)=Y 82 : IF (IDIM.EQ.3) XCOOR(**)=TTEMP 83 : XCOOR(**)=DENSIT 84 : IP=ITE 85 : ICPR(**)=ITE 86 : III=ICPR(/1) 87 : IDCP(**)=III 88 : IVU(**)=1 89 : IMILL(**)=0 89 : CALL PROMOD(ICPR,XPROJ,III,4,IBOUJ) 90 : 130 CONTINUE 90 : call insegt(3,iresu) 91 : TTEMP=XPROJ(3,IP) 92 : XTR(I)=XPROJ(1,IP) 93 : YTR(I)=XPROJ(2,IP) 93 : IF (I.NE.1) CALL POLRL(2,XTR(I-1),YTR(I-1),ZTR) 94 : IF (I.EQ.NBNN.AND.IPT8.ITYPEL.GT.3) THEN 95 : XTR(2)=XTR(I) 96 : YTR(2)=YTR(I) 96 : CALL POLRL(2,XTR,YTR,ZTR) 97 : ENDIF 98 : IPT8.NUM(I,NBELEM)=IDCP(IP) 99 : 110 CONTINUE 100 : IPT8.ICOLOR(NBELEM)=IDCOUL 100 : CALL CHCOUL(IDNOIR) 101 : DO 140 I=1,NBNN 102 : IPR=ICPR(IPT8.NUM(I,NBELEM)) 103 : XTR(1)=XPROJ(1,IPR) 104 : YTR(1)=XPROJ(2,IPR) 105 : XTR(2)=XPROJ(1,IPR) 106 : YTR(2)=XPROJ(2,IPR) 106 : CALL POLRL(2,XTR,YTR,ZTR) 107 : IMILL(IPR)=1 108 : 140 CONTINUE 109 : 141 CONTINUE 110 : LEGEND(1)=' ' 111 : LEGEND(2)='Fin' 112 : LEGEND(3)='Cont' 112 : CALL MENU(LEGEND,3,4) 112 : CALL TRMESS('Fin pour arreter la definition d''elements') 112 : CALL TRAFF(IREP) 113 : IF (IREP.NE.1) GOTO 100 113 : CALL TRGET 114 : * ('Donnez si necessaire un nom aux elements crees :',ZONE) 115 : IF (ZONE(1:1).NE.' ') THEN 115 : CALL NOMOBJ('MAILLAGE',ZONE,IPT8) 116 : ENDIF 117 : LEGEND(1)=' ' 118 : LEGEND(2)='Ajou' 119 : LEGEND(3)='Cont' 119 : CALL MENU(LEGEND,3,4) 119 : CALL TRMESS('Ajou pour ajouter le maillage au maillage courant') 119 : CALL TRAFF(IREP) 120 : IF (IREP.NE.1) THEN 121 : SEGDES IPT8 122 : RETURN 123 : ENDIF 124 : IF (LISOUS(/1).EQ.0) THEN 125 : IF (ITYPEL.EQ.IPT8.ITYPEL) THEN 126 : NBELE0=NUM(/2) 127 : NBELE8=IPT8.NUM(/2) 128 : NBELEM=NBELE0+NBELE8 129 : NBNN=NUM(/1) 130 : NBREF=0 131 : NBSOUS=0 132 : SEGADJ MELEME 133 : DO 800 I=NBELE0+1,NBELEM 134 : ICOLOR(I)=IPT8.ICOLOR(I-NBELE0) 135 : DO 800 J=1,NBNN 136 : NUM(J,I)=IPT8.NUM(J,I-NBELE0) 137 : 800 CONTINUE 138 : SEGDES IPT8 139 : RETURN 140 : ENDIF 141 : SEGINI,IPT2=MELEME 142 : NBSOUS=2 143 : NBREF=0 144 : NBNN=0 145 : NBELEM=0 146 : SEGADJ MELEME 147 : ITYPEL=0 148 : LISOUS(1)=IPT2 149 : LISOUS(2)=IPT8 150 : RETURN 151 : ENDIF 152 : DO 810 IO=1,LISOUS(/1) 153 : IPT1=LISOUS(IO) 154 : IF (IPT1.ITYPEL.NE.IPT8.ITYPEL) GOTO 810 155 : NBELE1=IPT1.NUM(/2) 156 : NBELE8=IPT8.NUM(/2) 157 : NBELEM=NBELE1+NBELE8 158 : NBNN=IPT1.NUM(/1) 159 : NBREF=0 160 : NBSOUS=0 161 : SEGADJ IPT1 162 : DO 820 I=NBELE1+1,NBELEM 163 : IPT1.ICOLOR(I)=IPT8.ICOLOR(I-NBELE1) 164 : DO 820 J=1,NBNN 165 : IPT1.NUM(J,I)=IPT8.NUM(J,I-NBELE1) 166 : 820 CONTINUE 167 : SEGDES IPT8 168 : RETURN 169 : 810 CONTINUE 170 : NBELEM=0 171 : NBREF=0 172 : NBSOUS=LISOUS(/1)+1 173 : NBNN=0 174 : SEGADJ MELEME 175 : LISOUS(NBSOUS)=IPT8 176 : END 177 : 178 : 179 : 180 : 181 : 182 : 183 : 184 : 185 :
© Cast3M 2003 - All rights reserved.
Disclaimer