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  26/08/24    21:17:55     12622          
  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.         NSA(I)=NFI(I)
  195.    60 CONTINUE
  196. C
  197.       IF(ICAS.EQ.1)CALL PPLAN(1,FER,XPROJ,NDEB,NUMNP,tcval)
  198.       IF(ICAS.EQ.2)CALL PSPHE(1,FER,XPROJ,NDEB,NUMNP,IP1,tcval)
  199.       IF(ICAS.EQ.3)CALL PCYLI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,
  200.      $ tcval,isens)
  201.       IF(ICAS.EQ.4)CALL PCONE(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,
  202.      $ tcval,isens)
  203.       IF(ICAS.EQ.5)CALL PTORI(1,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval,
  204.      $ isens)
  205.       IF(ICAS.EQ.6)CALL PQUEL(1,FER,XPROJ,NDEB,NUMNP)
  206.       IF(ICAS.EQ.7)CALL SURFP5 (FER,XPROJ,NDEB,msurfp)
  207.       IF(IERR.NE.0) RETURN
  208. C
  209. C
  210. C
  211.       MNOMB = NBN(1)
  212.       NNOMB = NBN(2)
  213. C      CALL DALLAG(MNOMB,NNOMB,FER,XPROJ,MELEME,NUMELG,NUMNP)
  214. C
  215. C      REMPLACE PAR :
  216. C
  217. C      write(6,*) 'MELEME =',MELEME
  218.       CALL DALLOS(NBN,FER,XPROJ,NBLIG,NBCOL,NKCOIN,
  219.      >            MELEME,NUMELG,NUMNP,IERRDS)
  220. C      write(6,*) 'MELEME =',MELEME
  221. C
  222. C
  223.       IF( IERRDS.NE. 0 )  THEN
  224.                  CALL ERREUR(26)
  225.                  RETURN
  226.       ENDIF
  227. C        WRITE(6,*) 'ERREUR DANS DALLOS ',IERRDS
  228. C        GOTO 9999
  229. C      ENDIF
  230. C
  231. C      write(6,*) 'LE MAILLAGE EN SORTIE DE DALLOS'
  232. C      write(6,*) 'NBE,NBN =',NUMELG,NUMNP
  233. C      WRITE(6,*) ((MELEME.NUM(J,I),J=1,4),I=1,NUMELG)
  234. C      WRITE(6,*) ((XPROJ(J,I),J=1,XPROJ(/1)),I=1,NUMNP)
  235. C
  236. C            ==================================
  237. C     ------- FIN   DE MODIF - O.STAB 25.03.97 --------
  238. C            ==================================
  239.  
  240.       ITY=KSURF(ILCOUR)
  241.       ITYPEL=8
  242.       CALL CHANGS(NUMNP,NUMELG,ITY,MELEME,XPROJ,IPT6)
  243.       ID1=nbpts
  244.       IF(ICAS.EQ.1)CALL PPLAN(2,FER,XPROJ,NDEB,NUMNP,tcval)
  245.       IF(ICAS.EQ.2)CALL PSPHE(2,FER,XPROJ,NDEB,NUMNP,IP1,tcval)
  246.       IF(ICAS.EQ.3)CALL PCYLI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,
  247.      $ tcval,isens)
  248.       IF(ICAS.EQ.4)CALL PCONE(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,
  249.      $ tcval,isens)
  250.       IF(ICAS.EQ.5)CALL PTORI(2,FER,XPROJ,NDEB,NUMNP,IP1,IP2,IP3,tcval,
  251.      $ isens)
  252.       IF(ICAS.EQ.6)CALL PQUEL(2,FER,XPROJ,NDEB,NUMNP)
  253. *>>>>> P.M. 04/10/90
  254.       IF (ICAS.EQ.7) CALL SURFP6 (DALL,XPROJ,NDEB,NUMNP,1,msurfp)
  255. *<<<<<
  256.       SEGSUP,FER
  257. *
  258.       NBNN=NUM(/1)
  259.       NBREF=4
  260.       NBSOUS=0
  261.       NBELEM=NUMELG
  262.       SEGINI IPT5
  263.       IPT5.LISREF(1)=IPT1
  264.       IPT5.LISREF(2)=IPT2
  265.       IPT5.LISREF(3)=IPT3
  266.       IPT5.LISREF(4)=IPT4
  267.       IPT5.ITYPEL=KSURF(ILCOUR)
  268.       IDEC=ID1-NDEB+1
  269.       DO 1002 I=1,NBNN
  270.       DO 50 J=1,NBELEM
  271.       IANC=NUM(I,J)
  272.       IF (IANC.GE.NDEB) GOTO 61
  273.       IPT5.NUM(I,J)=NSA(IANC)
  274.       GOTO 50
  275.   61  IPT5.NUM(I,J)=IANC+IDEC
  276.   50  CONTINUE
  277.  1002 CONTINUE
  278.       DO 45 I=1,IPT5.NUM(/2)
  279.       IPT5.ICOLOR(I)=ICHCOL
  280.    45 CONTINUE
  281.       SEGSUP SAUV,MELEME
  282.       CALL ACTOBJ('MAILLAGE',IPT5,1)
  283.       CALL ECROBJ('MAILLAGE',IPT5)
  284.  1000 CONTINUE
  285.       RETURN
  286.  
  287.  1001 SEGSUP IPT5
  288.       END
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  

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