C PRDALL SOURCE CB215821 23/07/12 21:15:11 11704 C PRDALL SOURCE CHAT 06/03/29 21:29:12 5360 C MODIF : O.STAB / 29.10.96 / DALLAG EST REMPLACE PAR DALLOS QUI C AUTORISE UN NOMBRE DE NOEUDS DIFFERENTS SUR LES COTES EN VIS-A-VIS C CE SOUS-PROGRAMME INTERFACE DALLAG IL LIT LES DONNEES ET RAMENE C EN COORDONNEES LOCALES C SUBROUTINE PRDALL IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMELEME -INC SMCOORD C PIFFARD . RENAULT : AJOUT DES SEGMENTS IC1 A IC4 * SEGMENT IC1(50) * SEGMENT IC2(50) * SEGMENT IC3(50) * SEGMENT IC4(50) * DIMENSION NELD1(2),NELA1(2),NELD2(2),NELA2(2),NELD3(2),NELA3(2) * DIMENSION NELD4(2),NELA4(2) C REAL*8 TCVAL(13) SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR) SEGMENT XPROJ(3,IMAX) SEGMENT /SAUV/(NSA(MAI(ITOUR+1))) PARAMETER (LCAS = 7) c ITEST(0:NBCOUL-1) DIMENSION ITEST(0:30) CHARACTER*4 MCAS(LCAS) CHARACTER*4 DALL PARAMETER (DALL = 'DALL') INTEGER NKCOIN(4),NBN(4) DATA MCAS/'PLAN','SPHE','CYLI','CONI','TORI','QUEL','POLY'/ isens=0 mpsurf=0 * IF (KSURF(ILCOUR).EQ.0) THEN CALL ERREUR(16) RETURN END IF CALL LIRMOT(MCAS,LCAS,ICAS,0) IF (ICAS.EQ.0.AND.IDIM.EQ.2) ICAS=1 IF (IDIM.EQ.2.AND.(ICAS.GE.2.AND.ICAS.LE.5)) THEN MOTERR=MCAS(ICAS) CALL ERREUR(7) RETURN ENDIF * IF (ICAS.EQ.0) ICAS=6 * IF (ICAS .LE. 6) THEN CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU) CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU) CALL ACTOBJ('MAILLAGE',IPT1,1) CALL ACTOBJ('MAILLAGE',IPT2,1) CALL ACTOBJ('MAILLAGE',IPT3,1) CALL ACTOBJ('MAILLAGE',IPT4,1) IF (ICAS.NE.6) THEN IF (ICAS.GT.1) CALL LIROBJ('POINT ',IP1,1,IRETOU) IF (ICAS.GT.2) CALL LIROBJ('POINT ',IP2,1,IRETOU) IF (ICAS.EQ.5) CALL LIROBJ('POINT ',IP3,1,IRETOU) ENDIF ELSE * ICAS = 7 : CALL SURFP1 (DALL,IPT1,IPT2,IPT3,IPT4,IBID,msurfp) END IF IF (IERR.NE.0) RETURN NC = 4 * SEGACT IPT1,IPT2,IPT3,IPT4 IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) CALL ERREUR(16) IF (IPT1.ITYPEL.NE.IPT3.ITYPEL) CALL ERREUR(16) IF (IPT1.ITYPEL.NE.IPT4.ITYPEL) CALL ERREUR(16) IF (IERR.NE.0) GOTO 1000 C ================================== C ------- DEBUT DE MODIF - O.STAB 25.03.97 -------- C ================================== IF((IDIM.LE.1).OR.(IDIM.GT.3))THEN C WRITE (6,*) 'L OPERATEUR NE FONCTIONNE QU EN 2D OU 3D' CALL ERREUR(832) ENDIF C C --- TEST DES CARDINAUX --- C NBN(1) = IPT1.NUM(/2) NBN(2) = IPT2.NUM(/2) NBN(3) = IPT3.NUM(/2) NBN(4) = IPT4.NUM(/2) C DO 10 I=1,4 C WRITE (6,*) 'UN COTE N A PAS D ELEMENTS' IF(NBN(I).LE.0)CALL ERREUR(830) 10 CONTINUE C C IF(MOD(NBN(1)+NBN(2)+NBN(3)+NBN(4),2).NE.0)THEN C WRITE(6,*) 'LE NOMBRE TOTAL D ELEMENTS EST IMPAIR' CALL ERREUR(831) ENDIF C CALL G2NBKK(NBN(1),NBN(2),NBN(3),NBN(4), > NKCOIN(1),NKCOIN(2),NKCOIN(3),NKCOIN(4),IERRDS) C NBLIG = MAX(NBN(4)+NKCOIN(4)+NKCOIN(3), > NBN(2)+NKCOIN(2)+NKCOIN(1)) + 1 NBCOL = MAX(NKCOIN(4)+NBN(1)+NKCOIN(1), > NKCOIN(2)+NBN(3)+NKCOIN(3)) + 1 C C WRITE(6,*)'NBLIG,NBCOL = ',NBLIG,NBCOL C WRITE(6,*)'NBN = ',(NBN(I),I=1,4) C WRITE(6,*)'NKCOIN = ',(NKCOIN(I),I=1,4) C C MNOMB=IPT1.NUM(/2) C IF (MNOMB.NE.IPT3.NUM(/2)) CALL ERREUR(33) C NNOMB=IPT2.NUM(/2) C IF (NNOMB.NE.IPT4.NUM(/2)) CALL ERREUR(33) C ================================ C ------- FIN DE MODIF - O.STAB 25.03.97 -------- C ================================ C MNOMB=IPT1.NUM(/2) C IF (MNOMB.NE.IPT3.NUM(/2)) CALL ERREUR(33) C NNOMB=IPT2.NUM(/2) C IF (NNOMB.NE.IPT4.NUM(/2)) CALL ERREUR(33) IF (IERRDS.NE.0) THEN call erreur(26) GOTO 1000 ENDIF do 15 i=0,NBCOUL-1 itest(i)=0 15 continue DO 20 I=1,IPT1.NUM(/2) ITEST(IPT1.ICOLOR(I))=1 20 CONTINUE DO 25 I=1,IPT2.NUM(/2) ITEST(IPT2.ICOLOR(I))=1 25 CONTINUE DO 30 I=1,IPT3.NUM(/2) ITEST(IPT3.ICOLOR(I))=1 30 CONTINUE DO 35 I=1,IPT4.NUM(/2) ITEST(IPT4.ICOLOR(I))=1 35 CONTINUE ICHCOL=-1 DO 40 I=0,NBCOUL-1 IF (ITEST(I).EQ.1) THEN IF (ICHCOL.EQ.-1) THEN ICHCOL=I ELSE ICHCOL=ITABM(ICHCOL,I) ENDIF ENDIF 40 CONTINUE NBNN=IPT1.NUM(/1) C ================================== C ------- DEBUT DE MODIF - O.STAB 25.03.97 -------- C ================================== C NBELEM=2*MNOMB+2*NNOMB NBELEM= NBN(1)+NBN(2)+NBN(3)+NBN(4) NBREF=0 NBSOUS=0 SEGINI IPT5 IPT5.ITYPEL=IPT1.ITYPEL C C ON ASSEMBLE LES QUATRES COTES EN UN CONTOUR FERME C DO 100 I=1,NBNN DO 101 J=1,NBN(1) IPT5.NUM(I,J)=IPT1.NUM(I,J) 101 CONTINUE DO 102 J=1,NBN(2) IPT5.NUM(I,J+NBN(1))=IPT2.NUM(I,J) 102 CONTINUE DO 103 J=1,NBN(3) IPT5.NUM(I,J+NBN(1)+NBN(2))=IPT3.NUM(I,J) 103 CONTINUE DO 104 J=1,NBN(4) IPT5.NUM(I,J+NBN(1)+NBN(2)+NBN(3))=IPT4.NUM(I,J) 104 CONTINUE 100 CONTINUE IPT6=1 C C --- CONSTRUCTION DU POLYGONE DANS FER --- CALL AVTRSF(IPT5,FER,IPT6) IF (IERR.NE.0) GOTO 1001 SEGSUP IPT5 SEGINI SAUV DO 60 I=1,NSA(/1) 60 NSA(I)=NFI(I) C IF(ICAS.EQ.1)CALL PPLAN(1,FER,XPROJ,NDEB,NUMNP,tcval) IF(ICAS.EQ.2)CALL PSPHE(1,FER,XPROJ,NDEB,NUMNP,IP1,tcval) IF(ICAS.EQ.3)CALL PCYLI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2, $ tcval,isens) IF(ICAS.EQ.4)CALL PCONE(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2, $ tcval,isens) IF(ICAS.EQ.5)CALL PTORI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval, $ isens) IF(ICAS.EQ.6)CALL PQUEL(1,FER,XPROJ,NDEB,NUMNP) IF(ICAS.EQ.7)CALL SURFP5 (FER,XPROJ,NDEB,msurfp) IF(IERR.NE.0) RETURN C C C MNOMB = NBN(1) NNOMB = NBN(2) C CALL DALLAG(MNOMB,NNOMB,FER,XPROJ,MELEME,NUMELG,NUMNP) C C REMPLACE PAR : C C write(6,*) 'MELEME =',MELEME CALL DALLOS(NBN,FER,XPROJ,NBLIG,NBCOL,NKCOIN, > MELEME,NUMELG,NUMNP,IERRDS) C write(6,*) 'MELEME =',MELEME C C IF( IERRDS.NE. 0 ) THEN CALL ERREUR(26) RETURN ENDIF C WRITE(6,*) 'ERREUR DANS DALLOS ',IERRDS C GOTO 9999 C ENDIF C C write(6,*) 'LE MAILLAGE EN SORTIE DE DALLOS' C write(6,*) 'NBE,NBN =',NUMELG,NUMNP C WRITE(6,*) ((MELEME.NUM(J,I),J=1,4),I=1,NUMELG) C WRITE(6,*) ((XPROJ(J,I),J=1,XPROJ(/1)),I=1,NUMNP) C C ================================== C ------- FIN DE MODIF - O.STAB 25.03.97 -------- C ================================== ITY=KSURF(ILCOUR) ITYPEL=8 CALL CHANGS(NUMNP,NUMELG,ITY,MELEME,XPROJ,IPT6) ID1=nbpts IF(ICAS.EQ.1)CALL PPLAN(2,FER,XPROJ,NDEB,NUMNP,tcval) IF(ICAS.EQ.2)CALL PSPHE(2,FER,XPROJ,NDEB,NUMNP,IP1,tcval) IF(ICAS.EQ.3)CALL PCYLI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2, $ tcval,isens) IF(ICAS.EQ.4)CALL PCONE(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2, $ tcval,isens) IF(ICAS.EQ.5)CALL PTORI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval, $ isens) IF(ICAS.EQ.6)CALL PQUEL(2,FER,XPROJ,NDEB,NUMNP) *>>>>> P.M. 04/10/90 IF (ICAS.EQ.7) CALL SURFP6 (DALL,XPROJ,NDEB,NUMNP,1,msurfp) *<<<<< SEGSUP,FER * NBNN=NUM(/1) NBREF=4 NBSOUS=0 NBELEM=NUMELG SEGINI IPT5 IPT5.LISREF(1)=IPT1 IPT5.LISREF(2)=IPT2 IPT5.LISREF(3)=IPT3 IPT5.LISREF(4)=IPT4 IPT5.ITYPEL=KSURF(ILCOUR) IDEC=ID1-NDEB+1 DO 50 I=1,NBNN DO 50 J=1,NBELEM IANC=NUM(I,J) IF (IANC.GE.NDEB) GOTO 61 IPT5.NUM(I,J)=NSA(IANC) GOTO 50 61 IPT5.NUM(I,J)=IANC+IDEC 50 CONTINUE DO 45 I=1,IPT5.NUM(/2) 45 IPT5.ICOLOR(I)=ICHCOL SEGSUP SAUV,MELEME CALL ACTOBJ('MAILLAGE',IPT5,1) CALL ECROBJ('MAILLAGE',IPT5) 1000 CONTINUE RETURN 1001 SEGSUP IPT5 END