Télécharger la plaquette Cast3M


fr en

Télécharger prsurf.eso

Retour à la liste

Numérotation des lignes : 

prsurf

  1. C PRSURF    SOURCE    PV        20/03/30    21:23:11     10567          
  2. C    CE SOUS PROGRAMME SERT D'INTERFACE POUR LE SOUS PROGRAMME TRANSF
  3. C    IL PREPARE SES DONNEES ET PROJETTE LES POINTS SUR UN PLAN
  4. C
  5.       SUBROUTINE PRSURF
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL*8 (A-H,O-Z)
  8. -INC SMELEME
  9.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12. -INC CCGEOME
  13. -INC SMCOORD
  14.       real*8 tcval(13)
  15.       SEGMENT XPROJ(3,1)
  16.       SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR)
  17.       SEGMENT/SAUV/(NSA(MAI(ITOUR+1)))
  18.       PARAMETER (LCAS = 6)
  19.       DIMENSION ITEST(0:30)
  20.       CHARACTER*4 MCLE(6)
  21.       DATA MCLE/'PLAN','SPHE','CYLI','CONI','TORI','POLY'/
  22.       isens=0
  23.       msurfp=0
  24.       DO 2 I=0,NBCOUL-1
  25.  2    ITEST(I)=0
  26.       IOBL=IDIM-2
  27.       NBCAS=6
  28.       IF (IDIM.EQ.2) NBCAS=1
  29.       CALL MESLIR(-230)
  30.       ICOND=1
  31.       IF (IDIM.EQ.2) ICOND=0
  32.       CALL LIRMOT(MCLE,NBCAS,ICAS,ICOND)
  33.       IF (IERR.GT.1) RETURN
  34.       IF (IDIM.EQ.2) ICAS=1
  35.       IF (ICAS .EQ. 6) THEN
  36.          CALL SURFP1 ('SURF',IBID,IBID,IBID,IBID,IPT1,msurfp)
  37.       ELSE
  38.          CALL MESLIR(-229)
  39.          CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  40.          CALL MESLIR(-228)
  41.          IF (ICAS.GT.1) CALL LIROBJ('POINT ',IP1,1,IRETOU)
  42.          CALL MESLIR(-227)
  43.          IF (ICAS.GT.2) CALL LIROBJ('POINT ',IP2,1,IRETOU)
  44.          CALL MESLIR(-226)
  45.          IF (ICAS.EQ.5) CALL LIROBJ('POINT ',IP3,1,IRETOU)
  46.       END IF
  47.       IF (IERR.NE.0) RETURN
  48.       IPCON=IPT1
  49.       SEGACT IPT1
  50.       IF (KSURF(IPT1.ITYPEL).NE.0) CALL ERREUR(16)
  51.       IF (IERR.GT.1) RETURN
  52.       IPT5=1
  53.       CALL AVTRSF(IPT1,FER,IPT5)
  54.       IF (IERR.GT.1) RETURN
  55.       DO 12 I=1,IPT1.NUM(/2)
  56.               ITEST(IPT1.ICOLOR(I))=1
  57.  12   CONTINUE
  58.       ICHCOL=-1
  59.       DO 14 I=0,NBCOUL-1
  60.         IF (ITEST(I).EQ.1) THEN
  61.           IF (ICHCOL.EQ.-1) THEN
  62.               ICHCOL=I
  63.           ELSE
  64.               ICHCOL=ITABM(ICHCOL,I)
  65.           ENDIF
  66.         ENDIF
  67.  14   CONTINUE
  68.       SEGINI SAUV
  69.       DO 60 I=1,NSA(/1)
  70.   60  NSA(I)=NFI(I)
  71.       ichp=0
  72. *  Lecture chpoin de densite
  73.       call LIROBJ('CHPOINT ',ichp,0,iretou)
  74.       if (iretou.eq.1) then
  75.       call ACTOBJ('CHPOINT ',ichp,1)
  76.         call menfor(ichp,fer)
  77.       endif
  78.       IF(ICAS.EQ.1)CALL PPLAN(1,FER,XPROJ ,NDEB,NUMNP,tcval)
  79.       IF(ICAS.EQ.2)CALL PSPHE(1,FER,XPROJ ,NDEB,NUMNP,IP1,tcval)
  80.       IF(ICAS.EQ.3)CALL PCYLI(1,FER,XPROJ ,NDEB,NUMNP,IP1,IP2,
  81.      $ tcval,isens)
  82.       IF(ICAS.EQ.4)CALL PCONE(1,FER,XPROJ ,NDEB,NUMNP,IP1,IP2,
  83.      $ tcval,isens)
  84.       IF(ICAS.EQ.5)CALL PTORI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval,
  85.      $ isens)
  86.       IF(ICAS.EQ.6)CALL SURFP5 (FER,XPROJ,NDEB,msurfp)
  87.       IF (IERR.GT.1) RETURN
  88.       if (ichp.ne.0) call menfo2(ichp,fer,xproj)
  89.         DO 84, NUCOT = 1, ITOUR
  90. *
  91.           IDEB = MAI(NUCOT)
  92.           IFIN = MAI(NUCOT+1)-1
  93. *
  94.           DO 84, IP2 = IDEB, IFIN
  95. *
  96. *
  97.   84      CONTINUE
  98.  
  99.  
  100. *  cas du maillage polygonal ==> dualisation
  101.       if (ILCOUR.eq.32) call dualis(fer,ifer,xproj,iproj)
  102.       CALL PRAJUS(FER,XPROJ,IPT2,NUMELG,NUMNP,ichp)
  103.       IF (IERR.GT.1) RETURN
  104.       IF (ICAS .EQ. 6) THEN
  105.          ID1=nbpts
  106.          CALL SURFP6 ('SURF',XPROJ,NDEB,NUMNP,0,msurfp)
  107.          CALL AMELI1 (IPT2,SAUV,ID1,NDEB,NUMNP,NUMELG)
  108.          NDEB = NUMNP + 1
  109.       END IF
  110. *
  111. *     Cas du maillage polygonal ==> dualisation
  112. *
  113.       IF (ILCOUR.eq.32) THEN
  114.          call duali2(ifer,xproj,iproj,ipt2,numelg,ndeb,numnp)
  115.       ELSE
  116.         IPT2.ITYPEL=4
  117.         IF (KSURF(ILCOUR).GE.8) IPT2.ITYPEL=8
  118.         ITY=IPT2.ITYPEL
  119.         IF (KSURF(ILCOUR).EQ.6.OR.KSURF(ILCOUR).EQ.10) ITY=ITY+2
  120.         CALL CHANGS(NUMNP,NUMELG,ITY,IPT2,XPROJ,IPT5)
  121.       ENDIF
  122.       ID1=nbpts
  123.       IF(ICAS.EQ.1)CALL PPLAN(2,FER,XPROJ ,NDEB,NUMNP,tcval)
  124.       IF(ICAS.EQ.2)CALL PSPHE(2,FER,XPROJ ,NDEB,NUMNP,IP1,tcval)
  125.       IF(ICAS.EQ.3)CALL PCYLI(2,FER,XPROJ ,NDEB,NUMNP,IP1,IP2,
  126.      $ tcval,isens)
  127.       IF(ICAS.EQ.4)CALL PCONE(2,FER,XPROJ ,NDEB,NUMNP,IP1,IP2,
  128.      $ tcval,isens)
  129.       IF(ICAS.EQ.5)CALL PTORI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval,
  130.      $ isens)
  131.       IF(ICAS.EQ.6)CALL SURFP6 ('SURF',XPROJ,NDEB,NUMNP,1,msurfp)
  132.       IF (KSURF(ILCOUR).GE.8) GOTO 100
  133.       NBNN=IPT2.NUM(/1)
  134.       NBREF=1
  135.       NBSOUS=0
  136.       NBELEM=NUMELG
  137.       SEGINI IPT1
  138.       IDEC=ID1-NDEB+1
  139.       DO 50 J=1,NBELEM
  140.       IPT1.ICOLOR(J)=ICHCOL
  141.       DO 50 I=1,NBNN
  142.       IANC=IPT2.NUM(I,J)
  143.       IF (IANC.GE.NDEB) GOTO 61
  144.       IPT1.NUM(I,J)=NSA(IANC)
  145.       GOTO 50
  146.   61  IPT1.NUM(I,J)=IANC+IDEC
  147.   50  CONTINUE
  148.       SEGSUP SAUV
  149.       IPT1.ITYPEL=IPT2.ITYPEL
  150.       SEGSUP IPT2
  151.  200  CONTINUE
  152. *     IPT5=IPCON                   PARAIT INUTILE  PV |
  153. *     SEGINI ,IPT6=IPT5
  154. *     DO 210 I=1,IPT6.NUM(/2)
  155. *210   IPT6.ICOLOR(I)=ICHCOL
  156. *     IPT1.LISREF(1)=IPT6
  157.       IPT1.LISREF(1)=IPCON
  158.       CALL ECROBJ('MAILLAGE',IPT1)
  159.       RETURN
  160.  100  CONTINUE
  161. *
  162.       IF (ILCOUR .EQ. 32) THEN
  163. *
  164. *       Polygone
  165. *
  166.         IPT1 = IPT2
  167.         NBSOUS=IPT1.LISOUS(/1)
  168.         IDEC=ID1-NDEB+1
  169.         NBELEM=0
  170.         NBNN=0
  171.         NBREF=1
  172.         SEGADJ IPT1
  173.         IPT1.LISREF(1)= IPCON
  174.         DO 80, NTEL = 1, IPT1.LISOUS(/1)
  175.           IPT3 = IPT1.LISOUS(NTEL)
  176.           NBELEM = IPT3.NUM(/2)
  177.           DO 80, NBEL = 1, NBELEM
  178.             IPT3.ICOLOR(NBEL) = ICHCOL
  179.             DO 80, NUN = 1, IPT3.NUM(/1)
  180.               IANC=IPT3.NUM(NUN,NBEL)
  181.               IF (IANC .GE.NDEB) THEN
  182.                 IPT3.NUM(NUN,NBEL)=IANC+IDEC
  183.               ELSE
  184.                 IPT3.NUM(NUN,NBEL)=NSA(IANC)
  185.               ENDIF
  186.    80   CONTINUE
  187.         CALL ACTOBJ('MAILLAGE',IPT1,1)
  188.         CALL ECROBJ('MAILLAGE',IPT1)
  189.         RETURN
  190. *
  191.       ENDIF
  192. C   ON A DES CARRES ET DES TRIANGLES
  193.       NBRE=IPT2.NUM(/1)
  194.       IDEC=ID1-NDEB+1
  195.       NBSOUS=0
  196.       NBREF=0
  197.       NBTRI=0
  198.       DO 101 I=1,NUMELG
  199.       IF (IPT2.NUM(NBRE,I).NE.0) GOTO 101
  200.       NBTRI=NBTRI+1
  201.  101  CONTINUE
  202.       NBELEM=NBTRI
  203.       IF (NBTRI.EQ.NUMELG) NBREF=1
  204.       NBNN=3
  205.       IF (NBTRI.EQ.0) GOTO 104
  206.       IF (NBRE.EQ.8) NBNN=6
  207.       NBNNT=NBNN
  208.       SEGINI IPT3
  209. C  A CAUSE DE L'OPTIMISEUR IBM  (POUR AVOIR IPT4<>0)
  210.       IPT4=IPT3
  211.       IPT3.ITYPEL=4
  212.       IF (NBRE.EQ.8) IPT3.ITYPEL=6
  213.  104  CONTINUE
  214.       NBNN=NBRE
  215.       NBNNQ=NBNN
  216.       NBELEM=NUMELG-NBTRI
  217.       IF (NBELEM.EQ.0) GOTO 105
  218.       IF (NBELEM.EQ.NUMELG) NBREF=1
  219.       SEGINI IPT4
  220. C  TOUJOURS L'OPTIMISEUR
  221.       IF (NBTRI.EQ.0) IPT3=IPT4
  222.       IPT4.ITYPEL=8
  223.       IF (NBRE.EQ.8) IPT4.ITYPEL=10
  224.  105  CONTINUE
  225.       J=0
  226.       K=0
  227.       DO 102 I=1,NUMELG
  228.       IF (IPT2.NUM(NBRE,I).NE.0) GOTO 103
  229.       J=J+1
  230.       IPT3.ICOLOR(J)=ICHCOL
  231.       DO 110 L=1,NBNNT
  232.       IANC=IPT2.NUM(L,I)
  233.       IF (IANC.GE.NDEB) GOTO 111
  234.       IPT3.NUM(L,J)=NSA(IANC)
  235.       GOTO 110
  236.  111  IPT3.NUM(L,J)=IANC+IDEC
  237.  110  CONTINUE
  238.       GOTO 102
  239.  103  K=K+1
  240.       IPT4.ICOLOR(K)=ICHCOL
  241.       DO 120 L=1,NBNNQ
  242.       IANC=IPT2.NUM(L,I)
  243.       IF (IANC.GE.NDEB) GOTO 121
  244.       IPT4.NUM(L,K)=NSA(IANC)
  245.       GOTO 120
  246.  121  IPT4.NUM(L,K)=IANC+IDEC
  247.  120  CONTINUE
  248.  102  CONTINUE
  249.       SEGSUP IPT2,SAUV
  250.       NBNN=0
  251.       NBQUA=NBELEM
  252.       NBELEM=0
  253.       NBSOUS=0
  254.       IF (NBTRI.NE.0) NBSOUS=NBSOUS+1
  255.       IF (NBQUA.NE.0) NBSOUS=NBSOUS+1
  256.       IF (NBSOUS.EQ.1) GOTO 180
  257.       NBREF=1
  258.       SEGINI IPT1
  259.       ISOUS=0
  260.       IF (NBTRI.EQ.0) GOTO 171
  261.       ISOUS=ISOUS+1
  262.       IPT1.LISOUS(ISOUS)=IPT3
  263.  171  CONTINUE
  264.       IF (NBQUA.EQ.0) GOTO 172
  265.       ISOUS=ISOUS+1
  266.       IPT1.LISOUS(ISOUS)=IPT4
  267.  172  CONTINUE
  268.       GOTO 200
  269.  180  CONTINUE
  270.       IF (NBTRI.NE.0) IPT1=IPT3
  271.       IF (NBQUA.NE.0) IPT1=IPT4
  272.       SEGACT IPT1*MOD
  273.       IPT1.LISREF(1)=IPCON
  274.       GOTO 200
  275.       END
  276.  
  277.  
  278.  
  279.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales