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

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