C LISSAG SOURCE FANDEUR 22/01/03 21:15:27 11136 SUBROUTINE LISSAG IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMLREEL -INC SMCHPOI -INC SMCOORD SEGMENT EDICON INTEGER KSTRT, KSTEP, NMIR, IS REAL*8 CROT , SROT , SYMFCT LOGICAL LREAL, LIMAG ENDSEGMENT SEGMENT ICPR(nbpts) SEGMENT IVOISI INTEGER IVOI(LL,MM),INB(MM) ENDSEGMENT SEGMENT ICOO REAL*8 X(MV),Y(MV),P(MV),WNODE(MV) INTEGER LISVO(MV) ENDSEGMENT SEGMENT IVAL REAL*8 VAL(nbpts) ENDSEGMENT SEGMENT ITRAVA REAL*8 KENN(M42,2),SIGMA(M42),DELRHO(M42),C(M50,M50) REAL*8 AK(M50),UM(M50),RM(M50) INTEGER IL(M50) ENDSEGMENT CHARACTER*4 MCLE(3) DATA MCLE/'PLAN','AXIS','POID'/ IF (IDIM .NE. 2) THEN CALL ERREUR(19) RETURN ENDIF U=0 UX=1 UY=2 UXX=3 UXY=4 UYY=5 CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIRENT ( ITYPE,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIRMOT ( MCLE,2,ICOOR,1) IF(IERR.NE.0) RETURN CALL LIRMOT( MCLE(3),1,IVAL,0) W1ST=1. W1ND=1. IF(IVAL.NE.0) THEN CALL LIRREE( W1ST,1,IRETOU) IF(IERR.NE.0) RETURN CALL LIRREE( W1ND,1,IRETOU) IF(IERR.NE.0) RETURN ENDIF CALL LIROBJ( 'POINT ', IPO,0,IRETOU) XORG=0.D0 YORG=0.D0 IF(IRETOU.NE.0) THEN XORG=XCOOR((IPO-1)*(IDIM+1) +1) YORG=XCOOR((IPO-1)*(IDIM+1) +1) ENDIF C C C MISE SOUS FORME D'ELEMENTS POINTS DU 2EME MAILLAGE. IL SERVIRA AU C CHPOINT RESULTAT C SEGACT IPT2 CALL CHANGE(IPT2,1) C WRITE(6,FMT='( '' SORTIE DE CHANGE '')') C C IVOI(I,J)=K VEUT DIRE QUE LE IEME VOISIN DU NOEUD J A LENUMERO GLOBAL K C INB(J)= K VEUT DIRE QUE LE JEME POINT LOCAL A K VOISIN C SEGINI ICPR SEGACT IPT1 MELEME = IPT1 IF(ITYPEL.EQ.1) THEN CALL ERREUR(16) RETURN ENDIF LIS = MAX(IPT1.LISOUS(/1),1) MM = 0 DO 2 L=1,LIS IF(IPT1.LISOUS(/1).NE.0) THEN MELEME=IPT1.LISOUS(L) SEGACT MELEME ENDIF NBEL= NUM(/2) NBP= NUM(/1) DO 3 I=1,NBEL DO 3 J=1,NBP IKI =NUM(J,I) IF(ICPR(IKI).NE.0) GO TO 3 MM = MM + 1 ICPR(IKI) = MM 3 CONTINUE IF(IPT1.LISOUS(/1).NE.0) THEN SEGDES MELEME ENDIF 2 CONTINUE 4 CONTINUE C INITIALISATION DE LL AU PIFIFL FAUDRA TESTER LES DEBORDEMENTS IV = NBP - 1 LL= IV * 3 SEGINI IVOISI MELEME = IPT1 LIS=MAX(1,IPT1.LISOUS(/1)) DO 6 LI=1,LIS IF(IPT1.LISOUS(/1).NE.0) THEN MELEME=IPT1.LISOUS(LI) SEGACT MELEME ENDIF DO 7 I=1,NUM(/2) DO 8 J=1,NUM(/1)-1 IGLO= NUM(J,I) ILO = ICPR(IGLO) DO 9 K = J+1,NUM(/1) IGLA= NUM(K,I) ILA = ICPR(IGLA) IF(INB(ILO).GT.0) THEN DO 10 L=1,INB(ILO) IF(IVOI(L,ILO).EQ.IGLA) GO TO 9 10 CONTINUE ENDIF INB(ILO)=INB(ILO)+1 INB(ILA)=INB(ILA)+1 IF(INB(ILO).GT.LL.OR.INB(ILA).GT.LL) THEN LL = LL + IV SEGADJ IVOISI ENDIF IVOI(INB(ILO),ILO)=IGLA IVOI(INB(ILA),ILA)=IGLO 9 CONTINUE 8 CONTINUE 7 CONTINUE IF(IPT1.LISOUS(/1).EQ.0) THEN SEGDES MELEME ENDIF 6 CONTINUE C WRITE(6,FMT='('' ICPR'',/,(10I6))')(ICPR(KJI),KJI=1,27) C WRITE(6,FMT='('' INB'',/,(10I6))')(INB(KJI),KJI=1,17) C DO 1234 KL=1,17 C WRITE(6,FMT='('' IVOI'',/,(10I6))')(IVOI(KJI,KL),KJI=1,INB(KL)) C 1234 CONTINUE SEGINI EDICON C C C ON BOUCLE SUR LES POINTS DU 2EME MAILLAGE LES ETAPES SONT: C RECHERCHE DU POINT DU MAILLAGE 1 LE PLUS PROCHE C FABRICATION DE LA PREMIERE COUCHE DE VOISINS C FABRICATION DE LA DEUXIEME COUCHE DE VOISINS C FABRICATION DU TABLEAU CONTENANT LES COORDONNEES C FABRICATIONS DU TABLEAU CONTENANT LES VALEURS DU CHAMP C APPEL DE LA FONCTION LISSAGE C REMPLISSAGE DU CHPOINT RESULTAT C FIN DE BOUCLE C C ECLATEMENT DU CHPOINT INITIAL C SEGACT MCHPOI NAT=JATTRI(/1) IF(IPCHP(/1).NE.1) CALL ERREUR (25) IF(IERR.NE.0) RETURN MSOUPO=IPCHP(1) SEGACT MSOUPO IPT3=IGEOC SEGACT IPT3 MPOVAL=IPOVAL SEGINI IVAL SEGACT MPOVAL DO 19 I=1,IPT3.NUM(/2) IGLO=IPT3.NUM(1,I) VAL(IGLO)=VPOCHA(I,1) 19 CONTINUE SEGDES MPOVAL,IPT3 C CREATION DU CHPOINT RESULTAT NSOUPO=1 SEGINI MCHPO1 DO 18 II=1,NAT MCHPO1.JATTRI(II)=JATTRI(II) 18 CONTINUE NC=7 SEGINI MSOUPO MCHPO1.IPCHP(1)=MSOUPO MCHPO1.IFOPOI=IFOUR SEGDES MCHPO1,MCHPOI NOCOMP(1)='A' NOCOMP(2)='BX' NOCOMP(3)='BY' NOCOMP(4)='BXX' NOCOMP(5)='BXY' NOCOMP(6)='BYX' NOCOMP(7)='BYY' NOHARM(1)=NIFOUR NOHARM(2)=NIFOUR NOHARM(3)=NIFOUR NOHARM(4)=NIFOUR NOHARM(5)=NIFOUR NOHARM(6)=NIFOUR NOHARM(7)=NIFOUR IGEOC=IPT2 SEGACT IPT2 N = IPT2.NUM(/2) SEGINI MPOVAL IPOVAL=MPOVAL SEGDES MSOUPO MV=50 SEGINI ICOO M42 = 42 M50 = 50 M42 = 84 M50 = 100 SEGINI ITRAVA IDIM1=IDIM+1 DO 20 I=1,IPT2.NUM(/2) IP=IPT2.NUM(1,I) DISMI=123456789.E+10 XA= XCOOR((IP-1)*IDIM1+1) XB= XCOOR((IP-1)*IDIM1+2) XC=0.D0 IPMIN=0 IF(IDIM.GT.2)XC=XCOOR((IP-1)*IDIM1+3) DO 21 J=1,ICPR(/1) IF(ICPR(J).EQ.0) GO TO 21 YA=XCOOR((J-1)*IDIM1 +1) YB=XCOOR((J-1)*IDIM1+2) YC=0.D0 IF(IDIM.GT.2)YC=XCOOR((J-1)*IDIM1+3) XDI=(YA-XA)*(YA-XA) + (YB-XB)*(YB-XB) + (YC-XC)*(YC-XC) IF(XDI.LE.DISMI) THEN DISMI=XDI IPMIN=J ENDIF 21 CONTINUE C WRITE(6,FMT='( '' POINT INI ET PROCHE '',2I5)') IP,IPMIN ILOC=ICPR(IPMIN) INN=INB(ILOC) IF(INN.GT.LISVO(/1)) THEN MV=MV+50 SEGSUP ICOO SEGINI ICOO ENDIF LISVO(1)=IPMIN DO 22 K=1,INN LISVO(K+1)=IVOI(K,ILOC) 22 CONTINUE IDE=INN+1 DO 23 K=1,INN+1 ILOA=ICPR(LISVO(K)) INV=INB(ILOA) DO 24 L=1,INV ICAND = IVOI(L,ILOA) DO 25 M=1,IDE IF(ICAND.EQ.LISVO(M) ) GO TO 24 25 CONTINUE IDE=IDE+1 IF(IDE.GT.MV) THEN MV=MV+50 SEGADJ ICOO ENDIF LISVO(IDE)=ICAND 24 CONTINUE 23 CONTINUE DO 26 K=1,IDE IGLO= LISVO(K) X(K)=XCOOR((IGLO-1)*(IDIM+1)+ 1) Y(K)=XCOOR((IGLO-1)*(IDIM+1)+ 2) WNODE(K)=W1ND P(K)=VAL(IGLO) 26 CONTINUE DO 27 K=1,INN 27 WNODE(K) = W1ST C WRITE(6,FMT= '('' LISTE DES VOISINS '',/,(10I6))')(LISVO(KJI), C $KJI=1,IDE) C WRITE(6,FMT= '('' WNODE '',/,(6E12.5))')(WNODE(KIJ),KIJ=1,IDE) C WRITE(6,FMT= '('' POTENTIEL'',/,(6E12.5))')(P(KIJ),KIJ=1,IDE) IBON=1 C CALCUL DES PARAMETRES M42CA = 84 M50CA = 100 IF ( M42.GT.M42CA) THEN M42=M42CA IBON=0 ENDIF IF(M50.GT.M50CA) THEN M50=M50CA IBON=0 ENDIF IF(IBON.EQ.0) THEN SEGSUP ITRAVA SEGINI ITRAVA ENDIF C APPEL DE LA FONCTION LISSAGE EN SORTIE U,UX,UY,UXX,UXY,UYY SONT C LES RESULTATS C KFLAG= 2 IF ( ICOOR.EQ.1) THEN C WRITE (ISORT,'(A)') ,'*********** CARTESIEN *************** ' CALL CARSYM (ITYPE,EDICON) CALL CARWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE, *XORG,YORG,IDE,EDICON,ICOO,ITRAVA) V1= U V2= UY V3= - UX IF (KFLAG.GT. 1) THEN V4 = UXY V5 = UYY V6 = - UXX V7 = - UXY END IF END IF IF ( ICOOR.EQ.2) THEN C WRITE (ISORT,'(A)') ,'*********** AXISYMETRIE*************** ' CALL CYLSYM (ITYPE,EDICON) CALL CYLWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE, *IDE,EDICON,ICOO,ITRAVA) V1 = U V2 = - UY V3 = UX IF (KFLAG.GT. 1) THEN V4 = - UXY V5 = - UYY V6 = UXX V7 = UXY END IF END IF C C C C C ON REMPLIT LES VALEURS C VPOCHA(I,1)=V1 VPOCHA(I,2)=V2 VPOCHA(I,3)=V3 VPOCHA(I,4)=V4 VPOCHA(I,5)=V5 VPOCHA(I,6)=V6 VPOCHA(I,7)=V7 20 CONTINUE SEGDES MPOVAL,IPT2 SEGSUP ICPR,ICOO,IVOISI,IVAL CALL ECROBJ('CHPOINT ',MCHPO1) RETURN END