Télécharger la plaquette Cast3M


fr en

Télécharger lissag.eso

Retour à la liste

Numérotation des lignes : 

lissag

  1. C LISSAG    SOURCE    CB215821  26/08/24    21:17:12     12622          
  2.       SUBROUTINE LISSAG
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. -INC PPARAM
  6. -INC CCOPTIO
  7. -INC SMELEME
  8. -INC SMLREEL
  9. -INC SMCHPOI
  10. -INC SMCOORD
  11.       SEGMENT EDICON
  12.         INTEGER  KSTRT, KSTEP, NMIR, IS
  13.         REAL*8  CROT , SROT , SYMFCT
  14.         LOGICAL LREAL, LIMAG
  15.       ENDSEGMENT
  16.       SEGMENT ICPR(nbpts)
  17.       SEGMENT IVOISI
  18.          INTEGER IVOI(LL,MM),INB(MM)
  19.       ENDSEGMENT
  20.       SEGMENT ICOO
  21.         REAL*8 X(MV),Y(MV),P(MV),WNODE(MV)
  22.         INTEGER LISVO(MV)
  23.       ENDSEGMENT
  24.       SEGMENT IVAL
  25.         REAL*8 VAL(nbpts)
  26.       ENDSEGMENT
  27.       SEGMENT ITRAVA
  28.         REAL*8 KENN(M42,2),SIGMA(M42),DELRHO(M42),C(M50,M50)
  29.         REAL*8 AK(M50),UM(M50),RM(M50)
  30.        INTEGER IL(M50)
  31.       ENDSEGMENT
  32.       CHARACTER*4 MCLE(3)
  33.       DATA MCLE/'PLAN','AXIS','POID'/
  34.       IF (IDIM .NE. 2) THEN
  35.           CALL ERREUR(19)
  36.           RETURN
  37.       ENDIF
  38.       U=0
  39.       UX=1
  40.       UY=2
  41.       UXX=3
  42.       UXY=4
  43.       UYY=5
  44.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  45.       IF(IERR.NE.0) RETURN
  46.       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  47.       IF(IERR.NE.0) RETURN
  48.       CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU)
  49.       IF(IERR.NE.0) RETURN
  50.       CALL LIRENT ( ITYPE,1,IRETOU)
  51.       IF(IERR.NE.0) RETURN
  52.       CALL LIRMOT ( MCLE,2,ICOOR,1)
  53.       IF(IERR.NE.0) RETURN
  54.       CALL LIRMOT( MCLE(3),1,IVAL,0)
  55.         W1ST=1.
  56.         W1ND=1.
  57.       IF(IVAL.NE.0) THEN
  58.            CALL LIRREE( W1ST,1,IRETOU)
  59.       IF(IERR.NE.0) RETURN
  60.            CALL LIRREE( W1ND,1,IRETOU)
  61.       IF(IERR.NE.0) RETURN
  62.       ENDIF
  63.       CALL LIROBJ( 'POINT   ', IPO,0,IRETOU)
  64.              XORG=0.D0
  65.              YORG=0.D0
  66.           IF(IRETOU.NE.0) THEN
  67.                 XORG=XCOOR((IPO-1)*(IDIM+1) +1)
  68.                 YORG=XCOOR((IPO-1)*(IDIM+1) +1)
  69.           ENDIF
  70. C
  71. C
  72. C  MISE SOUS FORME D'ELEMENTS POINTS DU 2EME MAILLAGE. IL SERVIRA AU
  73. C  CHPOINT RESULTAT
  74. C
  75.       SEGACT IPT2
  76.       CALL CHANGE(IPT2,1)
  77. C       WRITE(6,FMT='( '' SORTIE DE CHANGE '')')
  78. C
  79. C IVOI(I,J)=K VEUT DIRE QUE LE IEME VOISIN DU NOEUD J A LENUMERO GLOBAL K
  80. C INB(J)= K VEUT DIRE QUE LE JEME POINT LOCAL A K VOISIN
  81. C
  82.       SEGINI ICPR
  83.       SEGACT IPT1
  84.       MELEME = IPT1
  85.       IF(ITYPEL.EQ.1) THEN
  86.          CALL ERREUR(16)
  87.          RETURN
  88.       ENDIF
  89.       LIS = MAX(IPT1.LISOUS(/1),1)
  90.       MM =  0
  91.       DO 2 L=1,LIS
  92.       IF(IPT1.LISOUS(/1).NE.0) THEN
  93.          MELEME=IPT1.LISOUS(L)
  94.          SEGACT MELEME
  95.       ENDIF
  96.       NBEL= NUM(/2)
  97.       NBP= NUM(/1)
  98.       DO 28 I=1,NBEL
  99.         DO 3 J=1,NBP
  100.         IKI =NUM(J,I)
  101.         IF(ICPR(IKI).NE.0) GO TO 3
  102.         MM = MM + 1
  103.         ICPR(IKI) = MM
  104.    3  CONTINUE
  105.    28 CONTINUE
  106.       IF(IPT1.LISOUS(/1).NE.0) THEN
  107.          SEGDES MELEME
  108.       ENDIF
  109.    2  CONTINUE
  110.    4  CONTINUE
  111. C  INITIALISATION DE LL AU PIFIFL FAUDRA TESTER LES DEBORDEMENTS
  112.       IV = NBP - 1
  113.       LL= IV * 3
  114.       SEGINI IVOISI
  115.       MELEME = IPT1
  116.       LIS=MAX(1,IPT1.LISOUS(/1))
  117.       DO 6 LI=1,LIS
  118.       IF(IPT1.LISOUS(/1).NE.0) THEN
  119.         MELEME=IPT1.LISOUS(LI)
  120.         SEGACT MELEME
  121.       ENDIF
  122.       DO 7 I=1,NUM(/2)
  123.         DO 8 J=1,NUM(/1)-1
  124.           IGLO= NUM(J,I)
  125.           ILO = ICPR(IGLO)
  126.           DO 9 K = J+1,NUM(/1)
  127.              IGLA= NUM(K,I)
  128.              ILA = ICPR(IGLA)
  129.              IF(INB(ILO).GT.0) THEN
  130.                 DO 10 L=1,INB(ILO)
  131.                   IF(IVOI(L,ILO).EQ.IGLA) GO TO 9
  132.   10            CONTINUE
  133.              ENDIF
  134.              INB(ILO)=INB(ILO)+1
  135.              INB(ILA)=INB(ILA)+1
  136.              IF(INB(ILO).GT.LL.OR.INB(ILA).GT.LL) THEN
  137.                 LL = LL + IV
  138.                 SEGADJ IVOISI
  139.              ENDIF
  140.              IVOI(INB(ILO),ILO)=IGLA
  141.              IVOI(INB(ILA),ILA)=IGLO
  142.     9     CONTINUE
  143.     8   CONTINUE
  144.     7 CONTINUE
  145.       IF(IPT1.LISOUS(/1).EQ.0) THEN
  146.          SEGDES MELEME
  147.       ENDIF
  148.     6 CONTINUE
  149. C      WRITE(6,FMT='('' ICPR'',/,(10I6))')(ICPR(KJI),KJI=1,27)
  150. C      WRITE(6,FMT='('' INB'',/,(10I6))')(INB(KJI),KJI=1,17)
  151. C      DO 1234 KL=1,17
  152. C      WRITE(6,FMT='('' IVOI'',/,(10I6))')(IVOI(KJI,KL),KJI=1,INB(KL))
  153. C 1234 CONTINUE
  154.       SEGINI EDICON
  155. C
  156. C
  157. C  ON BOUCLE SUR LES POINTS DU 2EME  MAILLAGE LES ETAPES SONT:
  158. C  RECHERCHE DU POINT DU MAILLAGE 1 LE PLUS PROCHE
  159. C  FABRICATION DE LA PREMIERE COUCHE DE VOISINS
  160. C  FABRICATION DE LA DEUXIEME COUCHE DE VOISINS
  161. C  FABRICATION DU TABLEAU CONTENANT LES COORDONNEES
  162. C  FABRICATIONS DU TABLEAU CONTENANT LES VALEURS DU CHAMP
  163. C  APPEL DE LA FONCTION LISSAGE
  164. C  REMPLISSAGE DU CHPOINT RESULTAT
  165. C  FIN DE BOUCLE
  166. C
  167. C  ECLATEMENT DU CHPOINT INITIAL
  168. C
  169.       SEGACT MCHPOI
  170.       NAT=JATTRI(/1)
  171.       IF(IPCHP(/1).NE.1) CALL ERREUR (25)
  172.       IF(IERR.NE.0) RETURN
  173.       MSOUPO=IPCHP(1)
  174.       SEGACT MSOUPO
  175.       IPT3=IGEOC
  176.       SEGACT IPT3
  177.       MPOVAL=IPOVAL
  178.       SEGINI IVAL
  179.       SEGACT MPOVAL
  180.       DO 19 I=1,IPT3.NUM(/2)
  181.         IGLO=IPT3.NUM(1,I)
  182.         VAL(IGLO)=VPOCHA(I,1)
  183.    19 CONTINUE
  184.       SEGDES MPOVAL,IPT3
  185. C  CREATION DU CHPOINT RESULTAT
  186.       NSOUPO=1
  187.       SEGINI MCHPO1
  188.       DO 18 II=1,NAT
  189.         MCHPO1.JATTRI(II)=JATTRI(II)
  190.    18 CONTINUE
  191.       NC=7
  192.       SEGINI MSOUPO
  193.       MCHPO1.IPCHP(1)=MSOUPO
  194.       MCHPO1.IFOPOI=IFOUR
  195.       SEGDES MCHPO1,MCHPOI
  196.       NOCOMP(1)='A'
  197.       NOCOMP(2)='BX'
  198.       NOCOMP(3)='BY'
  199.       NOCOMP(4)='BXX'
  200.       NOCOMP(5)='BXY'
  201.       NOCOMP(6)='BYX'
  202.       NOCOMP(7)='BYY'
  203.       NOHARM(1)=NIFOUR
  204.       NOHARM(2)=NIFOUR
  205.       NOHARM(3)=NIFOUR
  206.       NOHARM(4)=NIFOUR
  207.       NOHARM(5)=NIFOUR
  208.       NOHARM(6)=NIFOUR
  209.       NOHARM(7)=NIFOUR
  210.       IGEOC=IPT2
  211.       SEGACT IPT2
  212.       N = IPT2.NUM(/2)
  213.       SEGINI MPOVAL
  214.       IPOVAL=MPOVAL
  215.       SEGDES MSOUPO
  216.       MV=50
  217.       SEGINI ICOO
  218.        M42 = 42
  219.        M50 = 50
  220.       M42 = 84
  221.       M50 = 100
  222.       SEGINI ITRAVA
  223.       IDIM1=IDIM+1
  224.       DO 20 I=1,IPT2.NUM(/2)
  225.         IP=IPT2.NUM(1,I)
  226.         DISMI=123456789.E+10
  227.         XA=  XCOOR((IP-1)*IDIM1+1)
  228.         XB=  XCOOR((IP-1)*IDIM1+2)
  229.         XC=0.D0
  230.         IPMIN=0
  231.         IF(IDIM.GT.2)XC=XCOOR((IP-1)*IDIM1+3)
  232.         DO 21 J=1,ICPR(/1)
  233.           IF(ICPR(J).EQ.0) GO TO 21
  234.           YA=XCOOR((J-1)*IDIM1 +1)
  235.           YB=XCOOR((J-1)*IDIM1+2)
  236.           YC=0.D0
  237.           IF(IDIM.GT.2)YC=XCOOR((J-1)*IDIM1+3)
  238.           XDI=(YA-XA)*(YA-XA) + (YB-XB)*(YB-XB) + (YC-XC)*(YC-XC)
  239.           IF(XDI.LE.DISMI) THEN
  240.             DISMI=XDI
  241.             IPMIN=J
  242.           ENDIF
  243.    21   CONTINUE
  244. C        WRITE(6,FMT='( '' POINT INI ET PROCHE '',2I5)') IP,IPMIN
  245.         ILOC=ICPR(IPMIN)
  246.         INN=INB(ILOC)
  247.         IF(INN.GT.LISVO(/1)) THEN
  248.           MV=MV+50
  249.           SEGSUP ICOO
  250.           SEGINI ICOO
  251.         ENDIF
  252.         LISVO(1)=IPMIN
  253.         DO 22 K=1,INN
  254.           LISVO(K+1)=IVOI(K,ILOC)
  255.    22   CONTINUE
  256.         IDE=INN+1
  257.         DO 23 K=1,INN+1
  258.           ILOA=ICPR(LISVO(K))
  259.           INV=INB(ILOA)
  260.           DO 24 L=1,INV
  261.             ICAND = IVOI(L,ILOA)
  262.             DO 25 M=1,IDE
  263.               IF(ICAND.EQ.LISVO(M) ) GO TO 24
  264.    25       CONTINUE
  265.             IDE=IDE+1
  266.             IF(IDE.GT.MV) THEN
  267.               MV=MV+50
  268.               SEGADJ ICOO
  269.             ENDIF
  270.             LISVO(IDE)=ICAND
  271.    24     CONTINUE
  272.    23   CONTINUE
  273.         DO 26 K=1,IDE
  274.           IGLO= LISVO(K)
  275.           X(K)=XCOOR((IGLO-1)*(IDIM+1)+ 1)
  276.           Y(K)=XCOOR((IGLO-1)*(IDIM+1)+ 2)
  277.           WNODE(K)=W1ND
  278.           P(K)=VAL(IGLO)
  279.    26   CONTINUE
  280.         DO 27 K=1,INN
  281.         WNODE(K) = W1ST
  282.    27   CONTINUE
  283. C       WRITE(6,FMT= '('' LISTE DES VOISINS '',/,(10I6))')(LISVO(KJI),
  284. C      $KJI=1,IDE)
  285. C       WRITE(6,FMT= '('' WNODE  '',/,(6E12.5))')(WNODE(KIJ),KIJ=1,IDE)
  286. C       WRITE(6,FMT= '('' POTENTIEL'',/,(6E12.5))')(P(KIJ),KIJ=1,IDE)
  287.         IBON=1
  288. C       CALCUL  DES PARAMETRES
  289.         M42CA = 84
  290.         M50CA = 100
  291.         IF ( M42.GT.M42CA) THEN
  292.            M42=M42CA
  293.            IBON=0
  294.          ENDIF
  295.          IF(M50.GT.M50CA) THEN
  296.              M50=M50CA
  297.            IBON=0
  298.           ENDIF
  299.          IF(IBON.EQ.0) THEN
  300.             SEGSUP ITRAVA
  301.            SEGINI ITRAVA
  302.          ENDIF
  303. C   APPEL DE LA FONCTION LISSAGE  EN SORTIE U,UX,UY,UXX,UXY,UYY SONT
  304. C   LES RESULTATS
  305. C
  306.       KFLAG= 2
  307.       IF ( ICOOR.EQ.1) THEN
  308. C       WRITE (ISORT,'(A)') ,'***********  CARTESIEN ***************  '
  309.       CALL CARSYM (ITYPE,EDICON)
  310.       CALL CARWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE,
  311.      *XORG,YORG,IDE,EDICON,ICOO,ITRAVA)
  312.       V1= U
  313.       V2=   UY
  314.       V3= - UX
  315.              IF (KFLAG.GT. 1) THEN
  316.       V4 = UXY
  317.       V5 = UYY
  318.       V6 = - UXX
  319.       V7 = - UXY
  320.              END IF
  321.       END IF
  322.       IF ( ICOOR.EQ.2) THEN
  323. C       WRITE (ISORT,'(A)') ,'***********  AXISYMETRIE***************  '
  324.       CALL CYLSYM (ITYPE,EDICON)
  325.       CALL CYLWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE,
  326.      *IDE,EDICON,ICOO,ITRAVA)
  327.       V1 = U
  328.       V2 = - UY
  329.       V3 =   UX
  330.              IF (KFLAG.GT. 1) THEN
  331.       V4 = - UXY
  332.       V5 = - UYY
  333.       V6 =  UXX
  334.       V7 =  UXY
  335.              END IF
  336.       END IF
  337. C
  338. C
  339. C
  340. C
  341. C   ON REMPLIT LES VALEURS
  342. C
  343.        VPOCHA(I,1)=V1
  344.        VPOCHA(I,2)=V2
  345.        VPOCHA(I,3)=V3
  346.        VPOCHA(I,4)=V4
  347.        VPOCHA(I,5)=V5
  348.        VPOCHA(I,6)=V6
  349.        VPOCHA(I,7)=V7
  350.    20  CONTINUE
  351.        SEGDES MPOVAL,IPT2
  352.        SEGSUP ICPR,ICOO,IVOISI,IVAL
  353.        CALL ECROBJ('CHPOINT ',MCHPO1)
  354.        RETURN
  355.        END
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  

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