Télécharger la plaquette Cast3M


fr en

Télécharger raft.eso

Retour à la liste

Numérotation des lignes : 

raft

  1. C RAFT      SOURCE    GOUNAND   24/10/08    21:15:06     12025          
  2.       SUBROUTINE RAFT
  3. C     **********************************************************************
  4. C     INTERFACE CASTEM 2000
  5. C
  6. C     SURF2 = RAFT (CHPO1) SURF1 ;
  7. C
  8. C
  9. C     OBJET :
  10. C     _______
  11. C
  12. C         L'OPERATEUR RAFT RAFINE UN MAILLAGE TRIANGULAIRE  (OBJET SURF1)
  13. C     POUR RESPECTER UNE CARTE DE TAILLEW DONNEE (OBJET CHPO1). LES ELEM-
  14. C     ENTS SONT DES TRIANGLES LINEAIRES QUELLES QUE SOIENT LES DIRECTIVES
  15. C     D'OPTION.
  16. C
  17. C
  18. C     DATE : 03.05.96 / 03.04.97
  19. C     ______
  20. C
  21. C     AUTEURS : O. STAB
  22. C     _________
  23. C
  24. C
  25. C     **********************************************************************
  26.       IMPLICIT INTEGER(I-N)
  27.       IMPLICIT REAL*8 (A-H,O-Z)
  28. C
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC SMELEME
  33. -INC SMCOORD
  34. -INC CCGEOME
  35. -INC SMCHPOI
  36.       SEGMENT ITRAVX
  37.        INTEGER ITVL (ITOTAI)
  38.       ENDSEGMENT
  39.       SEGMENT RTRAV
  40.        REAL*8 RTVL ( ITOTAR)
  41.       ENDSEGMENT
  42.       SEGMENT ICPR (nbpts)
  43.       SEGMENT ICPP (nbpts)
  44.       SEGMENT IRADEC
  45.        REAL*8 RADEC (MRIADEC)
  46.       ENDSEGMENT
  47.       DIMENSION IADEC(1)
  48.       LOGICAL LQUAD
  49. C elimination de l'external TC
  50. C      INTEGER  D2CHPO
  51. C      EXTERNAL D2CHPO
  52.       INTEGER       NRIADC,NITMAX,NRTMAX,NPONEW,IERRDS
  53. C     --- VARIABLES INTERNES ---
  54.       INTEGER NBN,NBE,IDIMC,NBNMAX,NBCMAX,IDE,NPOMAX,NBEMAX,ITRNOE
  55.       INTEGER ITRTRI,NOETRI,ITRAV,IRTRAV,NITMX2,NRTMX2,ICOORD
  56.       INTEGER I,NCC,NOEMAX
  57. C
  58.       CALL DSINIT
  59.       IERRDS = 0
  60. C        =======================
  61. C     --- 1.LECTURE DES DONNEES ---
  62. C        =======================
  63. C
  64. *     LECTURE DES OBJETS COURANTS (ENTREES)
  65. *     =====================================
  66.       IF(IDIM.NE.2) THEN
  67.         INTERR(1)=IDIM
  68. C       FONCTION INDISPONIBLE EN DIMENSION %I1
  69.         CALL ERREUR(709)
  70.         GOTO 999
  71.       ENDIF
  72. C
  73.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  74.       IF(IERR.NE.0) THEN
  75. C        ON A PAS TROUVE LE MAILLAGE
  76.          CALL ERREUR(503)
  77.          GOTO 999
  78.       ENDIF
  79. C
  80.       CALL LIRENT ( IVAL,0,IRETOU)
  81. C
  82.       SEGACT IPT1
  83.       IF (IPT1.LISOUS(/1).NE.0) THEN
  84.          CALL ERREUR(21)
  85.          GOTO 999
  86.       ENDIF
  87.  
  88.       NBE = IPT1.NUM(/2)
  89.       NBEINI = NBE
  90.       NBNTOT =  -1
  91.       IF(IRETOU.NE.0) THEN
  92.           IF( IVAL.LT.NBE )THEN
  93. C           Le nombre de noeuds ne peut ètre inférieur à %i1
  94. C           (nombre d'éléments)
  95.             INTERR(1) = NBE
  96.             CALL ERREUR(838)
  97.             SEGDES IPT1
  98.             GOTO 999
  99.          ENDIF
  100.          NBNTOT = IVAL
  101.       ENDIF
  102.  
  103.       NTYP=IPT1.ITYPEL
  104.       LQUAD=KDEGRE(NTYP).EQ.3
  105.       IF (LQUAD) THEN
  106.          IPT3=IPT1
  107.          CALL CHANL2(IPT3,IPT1)
  108.          IF (IERR.NE.0) RETURN
  109.          NTYP=IPT1.ITYPEL
  110.       ENDIF
  111. C
  112.       IF(NTYP.NE.4) THEN
  113. C         DONNEES INCOMPATIBLES
  114.          CALL ERREUR(21)
  115.          GOTO 999
  116.       ENDIF
  117. *
  118. *     LECTURE DU CHAMPS DE DENSITE
  119. *     ============================
  120. *
  121.       CALL LIROBJ('CHPOINT',MCHPO1,0,IRETOU)
  122.       IF(IRETOU.EQ.0)THEN
  123. C        ON A PAS TROUVE LE CHAMPS DE POINTS
  124.         IF(IIMPI.NE.0)  CALL ERREUR(839)
  125.          PCHPOI = 0
  126.       ELSE
  127.          PCHPOI = 1
  128.       ENDIF
  129. C
  130. C     ---- VERIFICATION DU CHPOINT ----
  131.       IF( PCHPOI.EQ.1)THEN
  132.       SEGACT MCHPO1
  133.       MSOUP1 = MCHPO1.IPCHP(1)
  134.       SEGACT MSOUP1
  135.       IF( MCHPO1.IPCHP(/1).GT.1)THEN
  136. C       IL Y A PLUS D'UN CHAMP PAR POINT LEQUEL CHOISIR ?
  137.         CALL ERREUR(840)
  138.         SEGDES IPT1,MCHPO1,MSOUP1
  139.         GOTO 999
  140.       ENDIF
  141. C
  142.       MPOVA1 = MSOUP1.IPOVAL
  143.       SEGACT MPOVA1
  144.       IF( MPOVA1.VPOCHA(/2).NE.1 )THEN
  145. C        Il y a plus d'une valeur par point ?!
  146.          CALL ERREUR(841)
  147.          SEGDES IPT1,MCHPO1,MSOUP1,MPOVA1
  148.          GOTO 999
  149.       ENDIF
  150.       SEGDES MCHPO1,MSOUP1,MPOVA1
  151.       ENDIF
  152. C     ---- FIN VERIFICATION DU CHPOINT ----
  153. *
  154. *
  155. *     ALLOCATION DE LA MEMOIRE
  156. *     =====================================
  157. *
  158. *
  159. *
  160. *     =====================================
  161.       IDIMC  = IDIM
  162.       NBNMAX = 3
  163.       NBCMAX = NBNMAX
  164.       NBADET = 50
  165. C
  166.       ICMEMO = 1
  167.       NBNINI = 0
  168. C
  169. C     --- POUR TESTER LES MESSAGE D'ERREUR ET LA REALLOCATION :
  170.       NBNREL = (10 * NBEINI ) / 2
  171.       NBNABS = 40000
  172.     5 CONTINUE
  173.       NBNREL = 7 * (NBEINI / 2)
  174.       IF( NBNINI.NE.0 )NBNREL = 7 * NBNINI
  175.       IF(NBNTOT.NE.-1) THEN
  176.           NPOMAX = NBNTOT*ICMEMO + NBADET
  177.       ELSE
  178.           NPOMAX = MAX(NBNREL,NBNABS)*ICMEMO + NBADET
  179.       ENDIF
  180.       NBEMAX = MAX((14*NBEINI),(2*NBNABS)) * ICMEMO
  181. C
  182.     6 CONTINUE
  183. C
  184. C      NITMAX =  20 * NPOMAX + 288 + 310
  185. C      NRTMAX = 12 * (NPOMAX + 12)
  186. C
  187.       NITMAX = (NBNMAX+NBCMAX)*NBEMAX +
  188.      >         NPOMAX +
  189.      >         MAX(7*NPOMAX , 6*NBADET+10) + 288
  190. C
  191. C     ITRNOE,ITRTRI, NOETRI,ITRAV (MAX SMAOCR,R2RAF)
  192. C
  193. C
  194.       NRTMAX = (IDIMC*NPOMAX) +
  195.      >          NBEMAX +
  196.      >          2*NBEMAX +
  197.      >         (IDIMC*NBEMAX) +
  198.      >         (IDIMC*NPOMAX) + 224
  199. C
  200. C     ICOORD, RADEC, ? , ITRAV (SPHERES+COORD)
  201. C
  202. C
  203. *
  204. *     TRANSFERT DANS LA STRUCTURE DE L'ALGO
  205. *     =====================================
  206. *
  207.       ICOORD = 1
  208.       ITRNOE = 1
  209.       IDE = 2
  210.       NCC = 1
  211. C     --- INITIALISATION EN CAS DE REALLOCATION ---
  212.       NBE = NBEINI
  213. *
  214. *     REMPLISSAGE DU TABLEAU DE CONNEXION
  215. *     ===================================
  216.       SEGACT IPT1
  217.       ITOTAI= NITMAX
  218.       SEGINI ITRAVX
  219.       segact mcoord*mod
  220.       NBANC = nbpts
  221.       SEGINI,ICPR,ICPP
  222.       ITOTAR = NRTMAX
  223.       SEGINI RTRAV
  224.       MRIADEC = NPOMAX
  225.       SEGINI IRADEC
  226.       INO = 0
  227.       DO 7765 I=1,NBE
  228.       DO 7764 J=1,NBNMAX
  229.         IA = IPT1.NUM(J,I)
  230.         IF( ICPR(IA).EQ.0 ) THEN
  231.           INO      = INO+1
  232.           ICPR(IA) = INO
  233.           ICPP(INO)= IA
  234.           DO 7763  K=1,IDIMC
  235.             RTVL((INO-1)*IDIMC+K+ICOORD-1)=
  236.      >           XCOOR((IA-1)*(IDIM+1)+K)
  237.  7763     CONTINUE
  238. C         --- PAR DEFAUT : LA DENSITE PONCTUELLE ---
  239.           RADEC(INO) = XCOOR(IA*(IDIM+1))
  240.         ENDIF
  241.         ITVL((I-1)*NBNMAX +J+ITRNOE-1) = ICPR(IA)
  242.  7764 CONTINUE
  243.  7765 CONTINUE
  244.       NBN = INO
  245.       NBNINI = INO
  246.       SEGDES IPT1
  247. C
  248. C     ON A LE NOMBRE EXACT DE NOEUDS DANS LE MAILLAGE
  249. C
  250.       NPONEW=NPOMAX-NBN
  251.       IF( NPONEW.LE.0 )THEN
  252.           IF( NBNTOT.NE.-1)THEN
  253. C           Le nombre de noeuds ne peut ètre inférieur à %i1
  254. C           (nombre de noeuds existants)
  255.             INTERR(1) = NBN
  256.             CALL ERREUR(844)
  257.             SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  258.             GOTO 999
  259.           ENDIF
  260.           NPOMAX = 5  * NBN
  261.           SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  262. C         Patience on reprend avec plus de mémoire...
  263.           CALL ERREUR(850)
  264.           GOTO 6
  265.       ENDIF
  266. *
  267.       IF(PCHPOI.EQ.1)THEN
  268. *
  269. *     TRANSFERT DE LA DENSITE
  270. *     -----------------------
  271.       SEGACT MCHPO1,MSOUP1,MPOVA1
  272. *     LECTURE DU MAILLAGE ASSOCIE AU CHPOINT
  273.       IPT2 = MSOUP1.IGEOC
  274.       SEGACT IPT2
  275. C      SEGINI IRADEC
  276.       NRIADC = MPOVA1.VPOCHA(/1)
  277. *
  278.       JNO=0
  279.       DO 8000 I=1,NRIADC
  280. *       ------- LECTURE DE L'ANCIEN NUMERO ---------
  281.         IA = IPT2.NUM(1,I)
  282. *       ------- NOUVEAU NUMERO --------
  283.         INO = ICPR(IA)
  284.         IF((INO.LT.1).OR.(INO.GT.NRIADC))THEN
  285. *          SEGDES MCHPO1,MSOUP1,MPOVA1,IPT2
  286. *          SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  287. *C         La densité (CHPOINT) doit ètre définie sur LE maillage donné.
  288. *          CALL ERREUR(843)
  289. *          GOTO 999
  290.         ELSE
  291.            JNO=JNO+1
  292.            RADEC(INO) = MPOVA1.VPOCHA(I,1)
  293.         ENDIF
  294.  8000 CONTINUE
  295.       IF( JNO.NE.NBN )THEN
  296.          SEGDES MCHPO1,MSOUP1,MPOVA1
  297.          SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  298. C         La densité (CHPOINT) doit ètre définie sur LE maillage donné.
  299.          CALL ERREUR(843)
  300.          GOTO 999
  301.       ENDIF
  302.  
  303.       SEGDES MCHPO1,MSOUP1,MPOVA1,IPT2
  304.       ELSE
  305. *     --------------------------------------------------
  306. *     PAS DE CHPOINT => ON VERIFIE QUE LA DENSITE DONNEE
  307. C     PAR RADEC(INO) = XCOORD(IA,3) EST ACCEPTABLE
  308. *     --------------------------------------------------
  309.         NRIADC = NBNINI
  310.         DO 8001 INO=1,NBNINI
  311.           IF( RADEC(INO).LE.0 )GOTO 8002
  312.  8001   CONTINUE
  313.         GOTO 8004
  314.  8002   NRIADC = 0
  315.  8004   CONTINUE
  316.       ENDIF
  317. *
  318. C        =======================
  319. C     --- 1.1. ALLOCATION       ---
  320. C        =======================
  321. C
  322. C
  323.       ITRTRI = ITRNOE + (NBEMAX * NBNMAX)
  324.       NOETRI = ITRTRI + (NBEMAX * NBCMAX)
  325.       ITRAV  = NOETRI + NPOMAX
  326.       NITMX2 = NITMAX - ITRAV
  327.       IRTRAV = NPOMAX * IDIMC + 1
  328.       NRTMX2 = NRTMAX - IRTRAV
  329.       NOEMAX = NPOMAX
  330. C
  331. C        =========================================
  332. C     --- 2. CREATION DE LA STRUCTURE DE DONNEES  ---
  333. C        =========================================
  334. C
  335. *
  336.       CALL SMAOCR(IDE,ITVL(ITRNOE),NBE,RTVL(ICOORD),
  337.      >            NBN,IDIMC,
  338.      >            ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),
  339.      >            NBCMAX,ITVL(NOETRI),NOEMAX,
  340.      >            ITVL(ITRAV),NITMX2,NCC,IERRDS)
  341. C
  342.       IF( IERRDS.NE.0 )THEN
  343.         IF( IERRDS.EQ.-2 )THEN
  344.           SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  345.           CALL ERREUR(850)
  346.           ICMEMO = ICMEMO + 1
  347.           IERRDS = 0
  348.           GOTO 5
  349.         ENDIF
  350. C       Maillage incorrect ?!!!
  351.         SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  352.         CALL ERREUR(844)
  353.         GOTO 999
  354.       ENDIF
  355. C
  356. C         ==================================
  357. C     --- 3. GENERATION DES NOEUDS ET
  358. C            INSERTION DANS LA TRIANGULATION ---
  359. C         ==================================
  360. C
  361.       NITMX2 = NITMAX - ITRAV
  362.       IRTRAV = NPOMAX * IDIMC + 1
  363.       NRTMX2 = NRTMAX - IRTRAV
  364.       NOEMAX = NPOMAX
  365. C
  366.       IF( NRIADC.EQ. 0 )THEN
  367. C        ========================
  368. C     --- RAFFINEMENT PAR DEFAUT ---
  369. C        ========================
  370. *
  371.       CALL R2RAF(ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),NBCMAX,
  372.      >     ITVL(NOETRI),NOEMAX,
  373.      >     RTVL(ICOORD),NBN,NBE,NPOMAX,NBEMAX,
  374.      >     ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,
  375.      >     IERRDS)
  376.       ELSE
  377. C        ========================
  378. C     --- RAFFINEMENT ITERATIF ---
  379. C        ========================
  380. C
  381.       CALL R2CPO(IADEC,RADEC,
  382. C      CALL R2CPO(D2CHPO,IADEC,RADEC,   modif TC
  383.      >     ITVL(ITRNOE),NBNMAX,
  384.      >     ITVL(ITRTRI),NBCMAX,
  385.      >     ITVL(NOETRI),NOEMAX,
  386.      >     RTVL(ICOORD),IDIMC,NBN,NBE,NPOMAX,NBEMAX,
  387.      >     ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,
  388.      >     NBENEW,IERRDS)
  389.       ENDIF
  390. C
  391. C
  392.       IF(IERRDS.NE.0)THEN
  393.         IF(IERRDS.EQ.-2)THEN
  394.           IF(NBNTOT.EQ.-1)THEN
  395. C           PAS DE LIMITATION SUR LES NOEUDS, LA MEMOIRE EVALUEE
  396. C           EST INSUFFISANTE
  397.             SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  398.             ICMEMO = ICMEMO + 1
  399. C           Patience on reprend avec plus de mémoire...
  400.             CALL ERREUR(850)
  401.             IERRDS = 0
  402.             GOTO 5
  403.           ENDIF
  404. C         LIMITATION SUR LES NOEUDS DONNE PAR L'UTILISATEUR
  405.           IERRDS = 0
  406.           GOTO 40
  407.         ENDIF
  408. C       IERRDS = -1 ...
  409.         CALL ERREUR(848)
  410. C       ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
  411. C        CALL ERREUR(27)
  412.         IERRDS = 0
  413.         GOTO 40
  414.       ENDIF
  415. C
  416. *
  417. *   REMPLISSAGE NOUVEL OBJET MAILLAGE ET TABLEAU DES COORDONNEES
  418. *   ============================================================
  419.   40  CONTINUE
  420.       NBELEM=NBE
  421.       NBNN=3
  422.       NBREF=0
  423.       NBSOUS=0
  424.       SEGINI MELEME
  425.       NBPTS = NBN-NBNINI+NBANC
  426.       SEGADJ MCOORD
  427.       DO 7781 I=1,NBN-NBNINI
  428.       XCOOR((NBANC +I-1)*(IDIM+1) +1) = RTVL((NBNINI+I-1)*IDIMC+1)
  429.       XCOOR((NBANC +I-1)*(IDIM+1) +2) = RTVL((NBNINI+I-1)*IDIMC+2)
  430. *     ---- POUR LA DENSITE : DENSITE COURANTE ----
  431.       XCOOR((NBANC +I-1)*(IDIM+1) +3) = DENSIT
  432.  7781 CONTINUE
  433. *
  434.       DO 7782 I=1,NBE
  435.        DO 7783 J=1,3
  436.        IA=ITVL((I-1)*NBNMAX +J-1+ITRNOE)
  437. C
  438.        IF ( IA .LE.NBNINI) THEN
  439.         IB = ICPP(IA)
  440.       ELSE
  441.         IB = IA -NBNINI +NBANC
  442.       ENDIF
  443.       NUM(J,I)=IB
  444.  7783 CONTINUE
  445.       ICOLOR(I) = IDCOUL
  446.  7782 CONTINUE
  447.       ITYPEL=4
  448.       SEGDES MELEME
  449.       SEGSUP ITRAVX,RTRAV,IRADEC,ICPR,ICPP
  450.       IPT2=MELEME
  451. * Transformation en quadratiques si necessaire
  452.       IF (LQUAD) THEN
  453.          IPT4=IPT2
  454.          CALL DEMCHA(IPT3,IPT4)
  455.          IF (IERR.NE.0) RETURN
  456.          SEGSUP IPT1
  457.          SEGSUP IPT2
  458.          IPT2=IPT4
  459.       ENDIF
  460.       CALL ACTOBJ('MAILLAGE',IPT2,1)
  461.       CALL ECROBJ('MAILLAGE',IPT2)
  462. C
  463.   999 END
  464.  
  465.  

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