C PRSURF SOURCE PV 20/03/30 21:23:11 10567 C CE SOUS PROGRAMME SERT D'INTERFACE POUR LE SOUS PROGRAMME TRANSF C IL PREPARE SES DONNEES ET PROJETTE LES POINTS SUR UN PLAN C SUBROUTINE PRSURF IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC SMELEME -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMCOORD real*8 tcval(13) SEGMENT XPROJ(3,1) SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR) SEGMENT/SAUV/(NSA(MAI(ITOUR+1))) PARAMETER (LCAS = 6) DIMENSION ITEST(0:30) CHARACTER*4 MCLE(6) DATA MCLE/'PLAN','SPHE','CYLI','CONI','TORI','POLY'/ isens=0 msurfp=0 DO 2 I=0,NBCOUL-1 2 ITEST(I)=0 IOBL=IDIM-2 NBCAS=6 IF (IDIM.EQ.2) NBCAS=1 CALL MESLIR(-230) ICOND=1 IF (IDIM.EQ.2) ICOND=0 CALL LIRMOT(MCLE,NBCAS,ICAS,ICOND) IF (IERR.GT.1) RETURN IF (IDIM.EQ.2) ICAS=1 IF (ICAS .EQ. 6) THEN CALL SURFP1 ('SURF',IBID,IBID,IBID,IBID,IPT1,msurfp) ELSE CALL MESLIR(-229) CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) CALL MESLIR(-228) IF (ICAS.GT.1) CALL LIROBJ('POINT ',IP1,1,IRETOU) CALL MESLIR(-227) IF (ICAS.GT.2) CALL LIROBJ('POINT ',IP2,1,IRETOU) CALL MESLIR(-226) IF (ICAS.EQ.5) CALL LIROBJ('POINT ',IP3,1,IRETOU) END IF IF (IERR.NE.0) RETURN IPCON=IPT1 SEGACT IPT1 IF (KSURF(IPT1.ITYPEL).NE.0) CALL ERREUR(16) IF (IERR.GT.1) RETURN IPT5=1 CALL AVTRSF(IPT1,FER,IPT5) IF (IERR.GT.1) RETURN DO 12 I=1,IPT1.NUM(/2) ITEST(IPT1.ICOLOR(I))=1 12 CONTINUE ICHCOL=-1 DO 14 I=0,NBCOUL-1 IF (ITEST(I).EQ.1) THEN IF (ICHCOL.EQ.-1) THEN ICHCOL=I ELSE ICHCOL=ITABM(ICHCOL,I) ENDIF ENDIF 14 CONTINUE SEGINI SAUV DO 60 I=1,NSA(/1) 60 NSA(I)=NFI(I) ichp=0 * Lecture chpoin de densite call LIROBJ('CHPOINT ',ichp,0,iretou) if (iretou.eq.1) then call ACTOBJ('CHPOINT ',ichp,1) call menfor(ichp,fer) endif 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 SURFP5 (FER,XPROJ,NDEB,msurfp) IF (IERR.GT.1) RETURN if (ichp.ne.0) call menfo2(ichp,fer,xproj) DO 84, NUCOT = 1, ITOUR * IDEB = MAI(NUCOT) IFIN = MAI(NUCOT+1)-1 * DO 84, IP2 = IDEB, IFIN * * 84 CONTINUE * cas du maillage polygonal ==> dualisation if (ILCOUR.eq.32) call dualis(fer,ifer,xproj,iproj) CALL PRAJUS(FER,XPROJ,IPT2,NUMELG,NUMNP,ichp) IF (IERR.GT.1) RETURN IF (ICAS .EQ. 6) THEN ID1=nbpts CALL SURFP6 ('SURF',XPROJ,NDEB,NUMNP,0,msurfp) CALL AMELI1 (IPT2,SAUV,ID1,NDEB,NUMNP,NUMELG) NDEB = NUMNP + 1 END IF * * Cas du maillage polygonal ==> dualisation * IF (ILCOUR.eq.32) THEN call duali2(ifer,xproj,iproj,ipt2,numelg,ndeb,numnp) ELSE IPT2.ITYPEL=4 IF (KSURF(ILCOUR).GE.8) IPT2.ITYPEL=8 ITY=IPT2.ITYPEL IF (KSURF(ILCOUR).EQ.6.OR.KSURF(ILCOUR).EQ.10) ITY=ITY+2 CALL CHANGS(NUMNP,NUMELG,ITY,IPT2,XPROJ,IPT5) ENDIF 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 SURFP6 ('SURF',XPROJ,NDEB,NUMNP,1,msurfp) IF (KSURF(ILCOUR).GE.8) GOTO 100 NBNN=IPT2.NUM(/1) NBREF=1 NBSOUS=0 NBELEM=NUMELG SEGINI IPT1 IDEC=ID1-NDEB+1 DO 50 J=1,NBELEM IPT1.ICOLOR(J)=ICHCOL DO 50 I=1,NBNN IANC=IPT2.NUM(I,J) IF (IANC.GE.NDEB) GOTO 61 IPT1.NUM(I,J)=NSA(IANC) GOTO 50 61 IPT1.NUM(I,J)=IANC+IDEC 50 CONTINUE SEGSUP SAUV IPT1.ITYPEL=IPT2.ITYPEL SEGSUP IPT2 200 CONTINUE * IPT5=IPCON PARAIT INUTILE PV | * SEGINI ,IPT6=IPT5 * DO 210 I=1,IPT6.NUM(/2) *210 IPT6.ICOLOR(I)=ICHCOL * IPT1.LISREF(1)=IPT6 IPT1.LISREF(1)=IPCON CALL ECROBJ('MAILLAGE',IPT1) RETURN 100 CONTINUE * IF (ILCOUR .EQ. 32) THEN * * Polygone * IPT1 = IPT2 NBSOUS=IPT1.LISOUS(/1) IDEC=ID1-NDEB+1 NBELEM=0 NBNN=0 NBREF=1 SEGADJ IPT1 IPT1.LISREF(1)= IPCON DO 80, NTEL = 1, IPT1.LISOUS(/1) IPT3 = IPT1.LISOUS(NTEL) NBELEM = IPT3.NUM(/2) DO 80, NBEL = 1, NBELEM IPT3.ICOLOR(NBEL) = ICHCOL DO 80, NUN = 1, IPT3.NUM(/1) IANC=IPT3.NUM(NUN,NBEL) IF (IANC .GE.NDEB) THEN IPT3.NUM(NUN,NBEL)=IANC+IDEC ELSE IPT3.NUM(NUN,NBEL)=NSA(IANC) ENDIF 80 CONTINUE CALL ACTOBJ('MAILLAGE',IPT1,1) CALL ECROBJ('MAILLAGE',IPT1) RETURN * ENDIF C ON A DES CARRES ET DES TRIANGLES NBRE=IPT2.NUM(/1) IDEC=ID1-NDEB+1 NBSOUS=0 NBREF=0 NBTRI=0 DO 101 I=1,NUMELG IF (IPT2.NUM(NBRE,I).NE.0) GOTO 101 NBTRI=NBTRI+1 101 CONTINUE NBELEM=NBTRI IF (NBTRI.EQ.NUMELG) NBREF=1 NBNN=3 IF (NBTRI.EQ.0) GOTO 104 IF (NBRE.EQ.8) NBNN=6 NBNNT=NBNN SEGINI IPT3 C A CAUSE DE L'OPTIMISEUR IBM (POUR AVOIR IPT4<>0) IPT4=IPT3 IPT3.ITYPEL=4 IF (NBRE.EQ.8) IPT3.ITYPEL=6 104 CONTINUE NBNN=NBRE NBNNQ=NBNN NBELEM=NUMELG-NBTRI IF (NBELEM.EQ.0) GOTO 105 IF (NBELEM.EQ.NUMELG) NBREF=1 SEGINI IPT4 C TOUJOURS L'OPTIMISEUR IF (NBTRI.EQ.0) IPT3=IPT4 IPT4.ITYPEL=8 IF (NBRE.EQ.8) IPT4.ITYPEL=10 105 CONTINUE J=0 K=0 DO 102 I=1,NUMELG IF (IPT2.NUM(NBRE,I).NE.0) GOTO 103 J=J+1 IPT3.ICOLOR(J)=ICHCOL DO 110 L=1,NBNNT IANC=IPT2.NUM(L,I) IF (IANC.GE.NDEB) GOTO 111 IPT3.NUM(L,J)=NSA(IANC) GOTO 110 111 IPT3.NUM(L,J)=IANC+IDEC 110 CONTINUE GOTO 102 103 K=K+1 IPT4.ICOLOR(K)=ICHCOL DO 120 L=1,NBNNQ IANC=IPT2.NUM(L,I) IF (IANC.GE.NDEB) GOTO 121 IPT4.NUM(L,K)=NSA(IANC) GOTO 120 121 IPT4.NUM(L,K)=IANC+IDEC 120 CONTINUE 102 CONTINUE SEGSUP IPT2,SAUV NBNN=0 NBQUA=NBELEM NBELEM=0 NBSOUS=0 IF (NBTRI.NE.0) NBSOUS=NBSOUS+1 IF (NBQUA.NE.0) NBSOUS=NBSOUS+1 IF (NBSOUS.EQ.1) GOTO 180 NBREF=1 SEGINI IPT1 ISOUS=0 IF (NBTRI.EQ.0) GOTO 171 ISOUS=ISOUS+1 IPT1.LISOUS(ISOUS)=IPT3 171 CONTINUE IF (NBQUA.EQ.0) GOTO 172 ISOUS=ISOUS+1 IPT1.LISOUS(ISOUS)=IPT4 172 CONTINUE GOTO 200 180 CONTINUE IF (NBTRI.NE.0) IPT1=IPT3 IF (NBQUA.NE.0) IPT1=IPT4 SEGACT IPT1*MOD IPT1.LISREF(1)=IPCON GOTO 200 END