1 : C PRDALL SOURCE CHAT 07/10/29 21:25:51 5940 2 : C PRDALL SOURCE CHAT 06/03/29 21:29:12 5360 3 : C MODIF : O.STAB / 29.10.96 / DALLAG EST REMPLACE PAR DALLOS QUI 4 : C AUTORISE UN NOMBRE DE NOEUDS DIFFERENTS SUR LES COTES EN VIS-A-VIS 5 : C CE SOUS-PROGRAMME INTERFACE DALLAG IL LIT LES DONNEES ET RAMENE 6 : C EN COORDONNEES LOCALES 7 : C 8 : SUBROUTINE PRDALL 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-Z) 11 : -INC CCOPTIO 12 : -INC CCGEOME 13 : -INC SMELEME 14 : -INC SMCOORD 15 : C PIFFARD . RENAULT : AJOUT DES SEGMENTS IC1 A IC4 16 : * SEGMENT IC1(50) 17 : * SEGMENT IC2(50) 18 : * SEGMENT IC3(50) 19 : * SEGMENT IC4(50) 20 : * DIMENSION NELD1(2),NELA1(2),NELD2(2),NELA2(2),NELD3(2),NELA3(2) 21 : * DIMENSION NELD4(2),NELA4(2) 22 : C 23 : REAL*8 TCVAL(13) 24 : SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR) 25 : SEGMENT XPROJ(3,IMAX) 26 : SEGMENT /SAUV/(NSA(MAI(ITOUR+1))) 27 : PARAMETER (LCAS = 7) 28 : DIMENSION ITEST(0:15) 29 : CHARACTER*4 MCAS(LCAS) 30 : CHARACTER*4 DALL 31 : PARAMETER (DALL = 'DALL') 32 : INTEGER NKCOIN(4),NBN(4) 33 : DATA MCAS/'PLAN','SPHE','CYLI','CONI','TORI','QUEL','POLY'/ 34 : isens=0 35 : mpsurf=0 36 : * 37 : IF (KSURF(ILCOUR).EQ.0) THEN 37 : CALL ERREUR(16) 38 : RETURN 39 : END IF 39 : CALL LIRMOT(MCAS,LCAS,ICAS,0) 40 : IF (ICAS.EQ.0.AND.IDIM.EQ.2) ICAS=1 41 : IF (IDIM.EQ.2.AND.(ICAS.GE.2.AND.ICAS.LE.5)) THEN 42 : MOTERR(1:4)=MCAS(ICAS) 42 : CALL ERREUR(7) 43 : RETURN 44 : ENDIF 45 : * 46 : IF (ICAS.EQ.0) ICAS=6 47 : * 48 : IF (ICAS .LE. 6) THEN 48 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 48 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 48 : CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU) 48 : CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU) 49 : IF (ICAS.NE.6) THEN 49 : IF (ICAS.GT.1) CALL LIROBJ('POINT ',IP1,1,IRETOU) 49 : IF (ICAS.GT.2) CALL LIROBJ('POINT ',IP2,1,IRETOU) 49 : IF (ICAS.EQ.5) CALL LIROBJ('POINT ',IP3,1,IRETOU) 50 : ENDIF 51 : ELSE 52 : * ICAS = 7 : 52 : CALL SURFP1 (DALL,IPT1,IPT2,IPT3,IPT4,IBID,msurfp) 53 : END IF 54 : IF (IERR.NE.0) RETURN 55 : NC = 4 56 : * 57 : SEGACT IPT1,IPT2,IPT3,IPT4 57 : IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) CALL ERREUR(16) 57 : IF (IPT1.ITYPEL.NE.IPT3.ITYPEL) CALL ERREUR(16) 57 : IF (IPT1.ITYPEL.NE.IPT4.ITYPEL) CALL ERREUR(16) 58 : IF (IERR.NE.0) GOTO 1000 59 : C ================================== 60 : C ------- DEBUT DE MODIF - O.STAB 25.03.97 -------- 61 : C ================================== 62 : IF((IDIM.LE.1).OR.(IDIM.GT.3))THEN 63 : C WRITE (6,*) 'L OPERATEUR NE FONCTIONNE QU EN 2D OU 3D' 63 : CALL ERREUR(832) 64 : ENDIF 65 : C 66 : C --- TEST DES CARDINAUX --- 67 : C 68 : NBN(1) = IPT1.NUM(/2) 69 : NBN(2) = IPT2.NUM(/2) 70 : NBN(3) = IPT3.NUM(/2) 71 : NBN(4) = IPT4.NUM(/2) 72 : C 73 : DO 10 I=1,4 74 : C WRITE (6,*) 'UN COTE N A PAS D ELEMENTS' 74 : IF(NBN(I).LE.0)CALL ERREUR(830) 75 : 10 CONTINUE 76 : C 77 : C 78 : IF(MOD(NBN(1)+NBN(2)+NBN(3)+NBN(4),2).NE.0)THEN 79 : C WRITE(6,*) 'LE NOMBRE TOTAL D ELEMENTS EST IMPAIR' 79 : CALL ERREUR(831) 80 : ENDIF 81 : C 81 : CALL G2NBKK(NBN(1),NBN(2),NBN(3),NBN(4), 82 : > NKCOIN(1),NKCOIN(2),NKCOIN(3),NKCOIN(4),IERRDS) 83 : C 84 : NBLIG = MAX(NBN(4)+NKCOIN(4)+NKCOIN(3), 85 : > NBN(2)+NKCOIN(2)+NKCOIN(1)) + 1 86 : NBCOL = MAX(NKCOIN(4)+NBN(1)+NKCOIN(1), 87 : > NKCOIN(2)+NBN(3)+NKCOIN(3)) + 1 88 : C 89 : C WRITE(6,*)'NBLIG,NBCOL = ',NBLIG,NBCOL 90 : C WRITE(6,*)'NBN = ',(NBN(I),I=1,4) 91 : C WRITE(6,*)'NKCOIN = ',(NKCOIN(I),I=1,4) 92 : C 93 : C MNOMB=IPT1.NUM(/2) 93 : C IF (MNOMB.NE.IPT3.NUM(/2)) CALL ERREUR(33) 94 : C NNOMB=IPT2.NUM(/2) 94 : C IF (NNOMB.NE.IPT4.NUM(/2)) CALL ERREUR(33) 95 : C ================================ 96 : C ------- FIN DE MODIF - O.STAB 25.03.97 -------- 97 : C ================================ 98 : C MNOMB=IPT1.NUM(/2) 98 : C IF (MNOMB.NE.IPT3.NUM(/2)) CALL ERREUR(33) 99 : C NNOMB=IPT2.NUM(/2) 99 : C IF (NNOMB.NE.IPT4.NUM(/2)) CALL ERREUR(33) 100 : IF (IERRDS.NE.0) THEN 100 : call erreur(26) 101 : GOTO 1000 102 : ENDIF 103 : do 15 i=0,15 104 : itest(i)=0 105 : 15 continue 106 : DO 20 I=1,IPT1.NUM(/2) 107 : ITEST(IPT1.ICOLOR(I))=1 108 : 20 CONTINUE 109 : DO 25 I=1,IPT2.NUM(/2) 110 : ITEST(IPT2.ICOLOR(I))=1 111 : 25 CONTINUE 112 : DO 30 I=1,IPT3.NUM(/2) 113 : ITEST(IPT3.ICOLOR(I))=1 114 : 30 CONTINUE 115 : DO 35 I=1,IPT4.NUM(/2) 116 : ITEST(IPT4.ICOLOR(I))=1 117 : 35 CONTINUE 118 : ICHCOL=-1 119 : DO 40 I=0,15 120 : IF (ITEST(I).EQ.1) THEN 121 : IF (ICHCOL.EQ.-1) THEN 122 : ICHCOL=I 123 : ELSE 124 : ICHCOL=ITABM(ICHCOL,I) 125 : ENDIF 126 : ENDIF 127 : 40 CONTINUE 128 : NBNN=IPT1.NUM(/1) 129 : C ================================== 130 : C ------- DEBUT DE MODIF - O.STAB 25.03.97 -------- 131 : C ================================== 132 : C NBELEM=2*MNOMB+2*NNOMB 133 : NBELEM= NBN(1)+NBN(2)+NBN(3)+NBN(4) 134 : NBREF=0 135 : NBSOUS=0 136 : SEGINI IPT5 137 : IPT5.ITYPEL=IPT1.ITYPEL 138 : C 139 : C ON ASSEMBLE LES QUATRES COTES EN UN CONTOUR FERME 140 : C 141 : DO 100 I=1,NBNN 142 : DO 101 J=1,NBN(1) 143 : IPT5.NUM(I,J)=IPT1.NUM(I,J) 144 : 101 CONTINUE 145 : DO 102 J=1,NBN(2) 146 : IPT5.NUM(I,J+NBN(1))=IPT2.NUM(I,J) 147 : 102 CONTINUE 148 : DO 103 J=1,NBN(3) 149 : IPT5.NUM(I,J+NBN(1)+NBN(2))=IPT3.NUM(I,J) 150 : 103 CONTINUE 151 : DO 104 J=1,NBN(4) 152 : IPT5.NUM(I,J+NBN(1)+NBN(2)+NBN(3))=IPT4.NUM(I,J) 153 : 104 CONTINUE 154 : 100 CONTINUE 155 : SEGDES IPT1,IPT2,IPT3,IPT4 156 : IPT6=1 157 : C 158 : C --- CONSTRUCTION DU POLYGONE DANS FER --- 158 : CALL AVTRSF(IPT5,FER,IPT6) 159 : IF (IERR.NE.0) GOTO 1001 160 : SEGSUP IPT5 161 : SEGINI SAUV 162 : DO 60 I=1,NSA(/1) 163 : 60 NSA(I)=NFI(I) 164 : C 164 : IF(ICAS.EQ.1)CALL PPLAN(1,FER,XPROJ,NDEB,NUMNP,tcval) 164 : IF(ICAS.EQ.2)CALL PSPHE(1,FER,XPROJ,NDEB,NUMNP,IP1,tcval) 164 : IF(ICAS.EQ.3)CALL PCYLI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2, 165 : $ tcval,isens) 165 : IF(ICAS.EQ.4)CALL PCONE(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2, 166 : $ tcval,isens) 166 : IF(ICAS.EQ.5)CALL PTORI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval, 167 : $ isens) 167 : IF(ICAS.EQ.6)CALL PQUEL(1,FER,XPROJ,NDEB,NUMNP) 167 : IF(ICAS.EQ.7)CALL SURFP5 (FER,XPROJ,NDEB,msurfp) 168 : IF(IERR.NE.0) RETURN 169 : C 170 : C 171 : C 172 : MNOMB = NBN(1) 173 : NNOMB = NBN(2) 173 : C CALL DALLAG(MNOMB,NNOMB,FER,XPROJ,MELEME,NUMELG,NUMNP) 174 : C 175 : C REMPLACE PAR : 176 : C 177 : C write(6,*) 'MELEME =',MELEME 177 : CALL DALLOS(NBN,FER,XPROJ,NBLIG,NBCOL,NKCOIN, 178 : > MELEME,NUMELG,NUMNP,IERRDS) 179 : C write(6,*) 'MELEME =',MELEME 180 : C 181 : C 182 : IF( IERRDS.NE. 0 ) THEN 182 : CALL ERREUR(26) 183 : RETURN 184 : ENDIF 185 : C WRITE(6,*) 'ERREUR DANS DALLOS ',IERRDS 186 : C GOTO 9999 187 : C ENDIF 188 : C 189 : C write(6,*) 'LE MAILLAGE EN SORTIE DE DALLOS' 190 : C write(6,*) 'NBE,NBN =',NUMELG,NUMNP 191 : C WRITE(6,*) ((MELEME.NUM(J,I),J=1,4),I=1,NUMELG) 192 : C WRITE(6,*) ((XPROJ(J,I),J=1,XPROJ(/1)),I=1,NUMNP) 193 : C 194 : C ================================== 195 : C ------- FIN DE MODIF - O.STAB 25.03.97 -------- 196 : C ================================== 197 : 198 : ITY=KSURF(ILCOUR) 199 : ITYPEL=8 199 : CALL CHANGS(NUMNP,NUMELG,ITY,MELEME,XPROJ,IPT6) 200 : ID1=XCOOR(/1)/(IDIM+1) 200 : IF(ICAS.EQ.1)CALL PPLAN(2,FER,XPROJ,NDEB,NUMNP,tcval) 200 : IF(ICAS.EQ.2)CALL PSPHE(2,FER,XPROJ,NDEB,NUMNP,IP1,tcval) 200 : IF(ICAS.EQ.3)CALL PCYLI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2, 201 : $ tcval,isens) 201 : IF(ICAS.EQ.4)CALL PCONE(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2, 202 : $ tcval,isens) 202 : IF(ICAS.EQ.5)CALL PTORI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval, 203 : $ isens) 203 : IF(ICAS.EQ.6)CALL PQUEL(2,FER,XPROJ,NDEB,NUMNP) 204 : *>>>>> P.M. 04/10/90 204 : IF (ICAS.EQ.7) CALL SURFP6 (DALL,XPROJ,NDEB,NUMNP,1,msurfp) 205 : *<<<<< 206 : SEGSUP,FER 207 : * 208 : NBNN=NUM(/1) 209 : NBREF=4 210 : NBSOUS=0 211 : NBELEM=NUMELG 212 : SEGINI IPT5 213 : IPT5.LISREF(1)=IPT1 214 : IPT5.LISREF(2)=IPT2 215 : IPT5.LISREF(3)=IPT3 216 : IPT5.LISREF(4)=IPT4 217 : IPT5.ITYPEL=KSURF(ILCOUR) 218 : IDEC=ID1-NDEB+1 219 : DO 50 I=1,NBNN 220 : DO 50 J=1,NBELEM 221 : IANC=NUM(I,J) 222 : IF (IANC.GE.NDEB) GOTO 61 223 : IPT5.NUM(I,J)=NSA(IANC) 224 : GOTO 50 225 : 61 IPT5.NUM(I,J)=IANC+IDEC 226 : 50 CONTINUE 227 : DO 45 I=1,IPT5.NUM(/2) 228 : 45 IPT5.ICOLOR(I)=ICHCOL 229 : SEGSUP SAUV,MELEME 230 : SEGDES IPT5 230 : CALL ECROBJ('MAILLAGE',IPT5) 231 : SEGDES IPT5 232 : 1000 SEGDES IPT1,IPT2 233 : IF (NC.GT.2) SEGDES IPT3 234 : IF (NC.GT.3) SEGDES IPT4 235 : RETURN 236 : 1001 SEGSUP IPT5 237 : RETURN 238 : END 239 : 240 : 241 : 242 : 243 : 244 : 245 : 246 :
© Cast3M 2003 - All rights reserved.
Disclaimer