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    FANDEUR   22/01/03    21:15:27     11136          
  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 3 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.       IF(IPT1.LISOUS(/1).NE.0) THEN
  106.          SEGDES MELEME
  107.       ENDIF
  108.    2  CONTINUE
  109.    4  CONTINUE
  110. C  INITIALISATION DE LL AU PIFIFL FAUDRA TESTER LES DEBORDEMENTS
  111.       IV = NBP - 1
  112.       LL= IV * 3
  113.       SEGINI IVOISI
  114.       MELEME = IPT1
  115.       LIS=MAX(1,IPT1.LISOUS(/1))
  116.       DO 6 LI=1,LIS
  117.       IF(IPT1.LISOUS(/1).NE.0) THEN
  118.         MELEME=IPT1.LISOUS(LI)
  119.         SEGACT MELEME
  120.       ENDIF
  121.       DO 7 I=1,NUM(/2)
  122.         DO 8 J=1,NUM(/1)-1
  123.           IGLO= NUM(J,I)
  124.           ILO = ICPR(IGLO)
  125.           DO 9 K = J+1,NUM(/1)
  126.              IGLA= NUM(K,I)
  127.              ILA = ICPR(IGLA)
  128.              IF(INB(ILO).GT.0) THEN
  129.                 DO 10 L=1,INB(ILO)
  130.                   IF(IVOI(L,ILO).EQ.IGLA) GO TO 9
  131.   10            CONTINUE
  132.              ENDIF
  133.              INB(ILO)=INB(ILO)+1
  134.              INB(ILA)=INB(ILA)+1
  135.              IF(INB(ILO).GT.LL.OR.INB(ILA).GT.LL) THEN
  136.                 LL = LL + IV
  137.                 SEGADJ IVOISI
  138.              ENDIF
  139.              IVOI(INB(ILO),ILO)=IGLA
  140.              IVOI(INB(ILA),ILA)=IGLO
  141.     9     CONTINUE
  142.     8   CONTINUE
  143.     7 CONTINUE
  144.       IF(IPT1.LISOUS(/1).EQ.0) THEN
  145.          SEGDES MELEME
  146.       ENDIF
  147.     6 CONTINUE
  148. C      WRITE(6,FMT='('' ICPR'',/,(10I6))')(ICPR(KJI),KJI=1,27)
  149. C      WRITE(6,FMT='('' INB'',/,(10I6))')(INB(KJI),KJI=1,17)
  150. C      DO 1234 KL=1,17
  151. C      WRITE(6,FMT='('' IVOI'',/,(10I6))')(IVOI(KJI,KL),KJI=1,INB(KL))
  152. C 1234 CONTINUE
  153.       SEGINI EDICON
  154. C
  155. C
  156. C  ON BOUCLE SUR LES POINTS DU 2EME  MAILLAGE LES ETAPES SONT:
  157. C  RECHERCHE DU POINT DU MAILLAGE 1 LE PLUS PROCHE
  158. C  FABRICATION DE LA PREMIERE COUCHE DE VOISINS
  159. C  FABRICATION DE LA DEUXIEME COUCHE DE VOISINS
  160. C  FABRICATION DU TABLEAU CONTENANT LES COORDONNEES
  161. C  FABRICATIONS DU TABLEAU CONTENANT LES VALEURS DU CHAMP
  162. C  APPEL DE LA FONCTION LISSAGE
  163. C  REMPLISSAGE DU CHPOINT RESULTAT
  164. C  FIN DE BOUCLE
  165. C
  166. C  ECLATEMENT DU CHPOINT INITIAL
  167. C
  168.       SEGACT MCHPOI
  169.       NAT=JATTRI(/1)
  170.       IF(IPCHP(/1).NE.1) CALL ERREUR (25)
  171.       IF(IERR.NE.0) RETURN
  172.       MSOUPO=IPCHP(1)
  173.       SEGACT MSOUPO
  174.       IPT3=IGEOC
  175.       SEGACT IPT3
  176.       MPOVAL=IPOVAL
  177.       SEGINI IVAL
  178.       SEGACT MPOVAL
  179.       DO 19 I=1,IPT3.NUM(/2)
  180.         IGLO=IPT3.NUM(1,I)
  181.         VAL(IGLO)=VPOCHA(I,1)
  182.    19 CONTINUE
  183.       SEGDES MPOVAL,IPT3
  184. C  CREATION DU CHPOINT RESULTAT
  185.       NSOUPO=1
  186.       SEGINI MCHPO1
  187.       DO 18 II=1,NAT
  188.         MCHPO1.JATTRI(II)=JATTRI(II)
  189.    18 CONTINUE
  190.       NC=7
  191.       SEGINI MSOUPO
  192.       MCHPO1.IPCHP(1)=MSOUPO
  193.       MCHPO1.IFOPOI=IFOUR
  194.       SEGDES MCHPO1,MCHPOI
  195.       NOCOMP(1)='A'
  196.       NOCOMP(2)='BX'
  197.       NOCOMP(3)='BY'
  198.       NOCOMP(4)='BXX'
  199.       NOCOMP(5)='BXY'
  200.       NOCOMP(6)='BYX'
  201.       NOCOMP(7)='BYY'
  202.       NOHARM(1)=NIFOUR
  203.       NOHARM(2)=NIFOUR
  204.       NOHARM(3)=NIFOUR
  205.       NOHARM(4)=NIFOUR
  206.       NOHARM(5)=NIFOUR
  207.       NOHARM(6)=NIFOUR
  208.       NOHARM(7)=NIFOUR
  209.       IGEOC=IPT2
  210.       SEGACT IPT2
  211.       N = IPT2.NUM(/2)
  212.       SEGINI MPOVAL
  213.       IPOVAL=MPOVAL
  214.       SEGDES MSOUPO
  215.       MV=50
  216.       SEGINI ICOO
  217.        M42 = 42
  218.        M50 = 50
  219.       M42 = 84
  220.       M50 = 100
  221.       SEGINI ITRAVA
  222.       IDIM1=IDIM+1
  223.       DO 20 I=1,IPT2.NUM(/2)
  224.         IP=IPT2.NUM(1,I)
  225.         DISMI=123456789.E+10
  226.         XA=  XCOOR((IP-1)*IDIM1+1)
  227.         XB=  XCOOR((IP-1)*IDIM1+2)
  228.         XC=0.D0
  229.         IPMIN=0
  230.         IF(IDIM.GT.2)XC=XCOOR((IP-1)*IDIM1+3)
  231.         DO 21 J=1,ICPR(/1)
  232.           IF(ICPR(J).EQ.0) GO TO 21
  233.           YA=XCOOR((J-1)*IDIM1 +1)
  234.           YB=XCOOR((J-1)*IDIM1+2)
  235.           YC=0.D0
  236.           IF(IDIM.GT.2)YC=XCOOR((J-1)*IDIM1+3)
  237.           XDI=(YA-XA)*(YA-XA) + (YB-XB)*(YB-XB) + (YC-XC)*(YC-XC)
  238.           IF(XDI.LE.DISMI) THEN
  239.             DISMI=XDI
  240.             IPMIN=J
  241.           ENDIF
  242.    21   CONTINUE
  243. C        WRITE(6,FMT='( '' POINT INI ET PROCHE '',2I5)') IP,IPMIN
  244.         ILOC=ICPR(IPMIN)
  245.         INN=INB(ILOC)
  246.         IF(INN.GT.LISVO(/1)) THEN
  247.           MV=MV+50
  248.           SEGSUP ICOO
  249.           SEGINI ICOO
  250.         ENDIF
  251.         LISVO(1)=IPMIN
  252.         DO 22 K=1,INN
  253.           LISVO(K+1)=IVOI(K,ILOC)
  254.    22   CONTINUE
  255.         IDE=INN+1
  256.         DO 23 K=1,INN+1
  257.           ILOA=ICPR(LISVO(K))
  258.           INV=INB(ILOA)
  259.           DO 24 L=1,INV
  260.             ICAND = IVOI(L,ILOA)
  261.             DO 25 M=1,IDE
  262.               IF(ICAND.EQ.LISVO(M) ) GO TO 24
  263.    25       CONTINUE
  264.             IDE=IDE+1
  265.             IF(IDE.GT.MV) THEN
  266.               MV=MV+50
  267.               SEGADJ ICOO
  268.             ENDIF
  269.             LISVO(IDE)=ICAND
  270.    24     CONTINUE
  271.    23   CONTINUE
  272.         DO 26 K=1,IDE
  273.           IGLO= LISVO(K)
  274.           X(K)=XCOOR((IGLO-1)*(IDIM+1)+ 1)
  275.           Y(K)=XCOOR((IGLO-1)*(IDIM+1)+ 2)
  276.           WNODE(K)=W1ND
  277.           P(K)=VAL(IGLO)
  278.    26   CONTINUE
  279.         DO 27 K=1,INN
  280.    27   WNODE(K) = W1ST
  281. C       WRITE(6,FMT= '('' LISTE DES VOISINS '',/,(10I6))')(LISVO(KJI),
  282. C      $KJI=1,IDE)
  283. C       WRITE(6,FMT= '('' WNODE  '',/,(6E12.5))')(WNODE(KIJ),KIJ=1,IDE)
  284. C       WRITE(6,FMT= '('' POTENTIEL'',/,(6E12.5))')(P(KIJ),KIJ=1,IDE)
  285.         IBON=1
  286. C       CALCUL  DES PARAMETRES
  287.         M42CA = 84
  288.         M50CA = 100
  289.         IF ( M42.GT.M42CA) THEN
  290.            M42=M42CA
  291.            IBON=0
  292.          ENDIF
  293.          IF(M50.GT.M50CA) THEN
  294.              M50=M50CA
  295.            IBON=0
  296.           ENDIF
  297.          IF(IBON.EQ.0) THEN
  298.             SEGSUP ITRAVA
  299.            SEGINI ITRAVA
  300.          ENDIF
  301. C   APPEL DE LA FONCTION LISSAGE  EN SORTIE U,UX,UY,UXX,UXY,UYY SONT
  302. C   LES RESULTATS
  303. C
  304.       KFLAG= 2
  305.       IF ( ICOOR.EQ.1) THEN
  306. C       WRITE (ISORT,'(A)') ,'***********  CARTESIEN ***************  '
  307.       CALL CARSYM (ITYPE,EDICON)
  308.       CALL CARWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE,
  309.      *XORG,YORG,IDE,EDICON,ICOO,ITRAVA)
  310.       V1= U
  311.       V2=   UY
  312.       V3= - UX
  313.              IF (KFLAG.GT. 1) THEN
  314.       V4 = UXY
  315.       V5 = UYY
  316.       V6 = - UXX
  317.       V7 = - UXY
  318.              END IF
  319.       END IF
  320.       IF ( ICOOR.EQ.2) THEN
  321. C       WRITE (ISORT,'(A)') ,'***********  AXISYMETRIE***************  '
  322.       CALL CYLSYM (ITYPE,EDICON)
  323.       CALL CYLWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE,
  324.      *IDE,EDICON,ICOO,ITRAVA)
  325.       V1 = U
  326.       V2 = - UY
  327.       V3 =   UX
  328.              IF (KFLAG.GT. 1) THEN
  329.       V4 = - UXY
  330.       V5 = - UYY
  331.       V6 =  UXX
  332.       V7 =  UXY
  333.              END IF
  334.       END IF
  335. C
  336. C
  337. C
  338. C
  339. C   ON REMPLIT LES VALEURS
  340. C
  341.        VPOCHA(I,1)=V1
  342.        VPOCHA(I,2)=V2
  343.        VPOCHA(I,3)=V3
  344.        VPOCHA(I,4)=V4
  345.        VPOCHA(I,5)=V5
  346.        VPOCHA(I,6)=V6
  347.        VPOCHA(I,7)=V7
  348.    20  CONTINUE
  349.        SEGDES MPOVAL,IPT2
  350.        SEGSUP ICPR,ICOO,IVOISI,IVAL
  351.        CALL ECROBJ('CHPOINT ',MCHPO1)
  352.        RETURN
  353.        END
  354.  
  355.  
  356.  
  357.  
  358.  

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