Télécharger la plaquette Cast3M


fr en

Télécharger prdall.eso

Retour à la liste

Numérotation des lignes : 

prdall

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

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