C ELPDY2 SOURCE FANDEUR 22/01/03 21:15:14 11136 SUBROUTINE ELPDY2 IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-B,D-H,O-Z) IMPLICIT COMPLEX*16(C) ************************************************************************ * * * * ELFE PLAQUE LAPLACE ........... * ---- ------ ------- * * ************************************************************************ -INC CCREEL -INC SMELEME -INC SMCHPOI -INC PPARAM -INC SMTABLE -INC SMLREEL * * POINTEUR MLRE10.MLREEL SEGMENT SBORD REAL*8 XBORD(15,NS) INTEGER IBORD (2 ,NS) ENDSEGMENT SEGMENT SCOIN REAL*8 XCOIN(14,NCOIN) INTEGER ICOIN(4 ,NCOIN) ENDSEGMENT SEGMENT SPOST REAL*8 PP0(2,NP0) COMPLEX*16 CRP (NP0) COMPLEX*16 CPOST(NS4) ENDSEGMENT SEGMENT SMAT COMPLEX*16 CMA1(NS4,NS4) COMPLEX*16 CSM (NS4) COMPLEX*16 CSOM2 (NS) COMPLEX*16 CRE (NS4) ENDSEGMENT SEGMENT SMAT2 COMPLEX*16 CMA2(NS4,NS4) COMPLEX*16 CSM2(NS4) ENDSEGMENT SEGMENT SMAI INTEGER IAUX(NS4) INTEGER IPIVO(NS4) INTEGER JPIVO(NS4) ENDSEGMENT * CHARACTER * (1) cAR0 CHARACTER * 1 cAr1 CHARACTER * 40 CHA1 CHARACTER * 40 CHA2 CHARACTER * 40 CHA3 LOGICAL LOG0 LOGICAL LOG1 DIMENSION PF0(2) REE1=0.D0 * *--1. LECTURE * * ( on fixe ntrap ntrap2,isingu,iregu au lieu de les lire) * ( on garde les branchements car les choix de methode ne * sont pas definitifs) CALL LIROBJ('MAILLAGE',IPT1 ,1,IRET) IF (IRET.EQ.0) RETURN CALL LIRREE(XE1,1,IRET) IF (IRET.EQ.0) RETURN CALL LIRREE(XH1,1,IRET) IF (IRET.EQ.0) RETURN CALL LIRREE(XNU1,1,IRET) IF (IRET.EQ.0) RETURN CALL LIRREE(XRO1,1,IRET) IF (IRET.EQ.0) RETURN CALL LIROBJ('LISTREEL',MLRE10,1,IRET) IF (IRET.EQ.0) RETURN NTRap=5 NTRap2=5 *- COINS CALL LIROBJ('MAILLAGE',IPT2 ,0,IRET1) IF ( IRET1 .EQ. 1) THEN SEGACT IPT2 NBELEM = IPT2.NUM(/2) NCOIN = NBELEM NC1 = Ncoin else NCOIN = 0 NC1 = 0 IPT2 = 0 ENDIF *- C.L. CALL LIROBJ('MCHAML',MCHELM ,1,IRET) IF (IRET.EQ.0) RETURN *- FORCE PONCTUELLE CALL LIROBJ('POINT',IPF0,1,IRET) IF (IRET.EQ.0) RETURN XF0 = 1.D0 *- POSTRAITEMENT CALL LIROBJ('POINT',IPP0,0,IRET1) CALL LIROBJ('MAILLAGE',IPT3,0,IRET2) IF ( IRET1 .EQ. 1) THEN NP0 = 1 ENDIF IF ( IRET2 .EQ. 1) THEN SEGACT IPT3 NP0 = IPT3.NUM(/2) ENDIF *- PARAMETRE LAPLACE CALL LIRREE(S0,1,IRET) IF (IRET.EQ.0) RETURN CALL LIROBJ('LISTREEL',MLREE1,1,IRET) IF (IRET.EQ.0) RETURN *- PARAMETREs methodes isingu=1 iregu=2 *--2. DIMENSIONNEMENT * SEGACT IPT1 NBELEM = IPT1.NUM(/2) NS = NBELEM NS4= 4 * NBELEM SEGINI SBORD SEGINI SCOIN SEGINI SMAT SEGINI SMAT2 SEGINI SMAI SEGINI SPOST SEGACT MLREE1 JG = MLREE1.PROG(/1) SEGACT MLRE10 SEGINI SPOST IF (NP0 .EQ.1) THEN SEGINI MLREE2 SEGINI MLREE3 ENDIF M=0 SEGINI MTABLE iENT0 =0 REE0 =0d0 CAR0 =' ' CAR1 = ' ' LOG0 =.TRUE. LOG1 =.TRUE. IPoin0=0 * *--3. CARACTERISTIQUES GEOMETRIQUES * CI = (0.D0,1.D0) XD = XE1* (XH1**3) / (12 * (1 - XNU1**2)) XNU = XNU1 CALL ELPGEO (SBORD,SCOIN,SPOST,IPT1,IPT2,IPF0,PF0,IPP0,IPT3) * *--4. REMPLISSAGE DES TERMES C.L. * CALL ELPDM2 (SBORD,SMAT,MCHELM) * *--5. on commence par un calcul statique bidon indispensable ISTAT = 1 CALL ELPDM1 (XBORD,IBORD,NS & ,XCOIN,ICOIN,NCOIN,NC1 & ,CMA1,CSM,CSOM2,NS4 & ,XD,XNU,NTRAP,NTRAP2,PF0,XF0,CB,ISTAT & ,isingu,iregu) DO 100 K1= 1,NS4 DO 200 K2= 1,NS4 CMA2(K1,K2) = CMA1(K1,K2) 200 CONTINUE CSM2(K1)= CSM(K1) CRE (K1)= 0D0 100 CONTINUE * CALL ELPDR1 (CMA2,CSM2 , CRE , NS4 ,IPIVO,JPIVO, IAUX ) * *--5. BOUCLE SUR LES FREQUENCES DEMANDEES PAR L' UTILISATEUR * DO 1000 I = 1,JG xcam = mlre10.prog(i) CS1 = S0 + CI*MLREE1.PROG(I) CB =( (CMPLX(-1)*(xcam*cs1 + XRO1*XH1*CS1*CS1)) & /XD )**CMPLX(.25D0) IF (MLREE1.PROG(I) .LT . 1E-10) THEN ISTAT = 1 ELSE ISTAT = 0 ENDIF CALL ELPDM1 (XBORD,IBORD,NS & ,XCOIN,ICOIN,NCOIN,NC1 & ,CMA1,CSM,CSOM2,NS4 & ,XD,XNU,NTRAP,NTRAP2,PF0,XF0,CB,ISTAT & ,isingu,iregu) DO 1100 K1= 1,NS4 DO 1200 K2= 1,NS4 CMA2(K1,K2) = CMA1(K1,K2) 1200 CONTINUE CSM2(K1)= CSM(K1) CRE (K1)= 0D0 1100 CONTINUE * IF ( I .EQ. 1 ) THEN CALL ELPDR1 (CMA2,CSM2 , CRE , NS4 ,IPIVO,JPIVO, IAUX ) ELSE CALL ELPDR2 (CMA2,CSM2 , CRE , NS4 ,IPIVO,JPIVO, IAUX ) ENDIF C c post-traitement c CALL ELPD99 (XBORD,IBORD,NS & ,XCOIN,ICOIN,NCOIN,NC1 & ,CRE,CPOST,CRP,NS4 & ,XD,XNU,NTRAP,PF0,XF0,PP0,NP0,CB,ISTAT) IF ( NP0 .EQ. 1) THEN CCP = CRP(1) XX = ABS (CCP) XR = CCP XI = -1*CI*(CCP - XR) XT = ATAN2(XI,XR)*180.D0/XPI MLREE2.PROG(I) = XX MLREE3.PROG(I) = XT ELSE N = NP0 NC= 2 NSOUPO = 1 SEGINI MPOVAL SEGINI MSOUPO IPOVAL = MPOVAL IGEOC = IPT3 NOCOMP(1) = 'MODU' NOCOMP(2) = 'PHAS' NOHARM(1) = 0 NOHARM(2) = 0 NAT=1 SEGINI MCHPOI MTYPOI = ' CREE PAR ELFE ' MOCHDE = ' ELFE ' IPCHP (1) = MSOUPO * MODU et PHAS sont des chpo diffus JATTRI(1) = 1 IFOPOI = 0 DO 1110 IP =1,NP0 CCP = CRP(IP) XX = ABS (CCP) XR = CCP XI = -1*CI*(CCP - XR) XT = ATAN2(XI,XR)*180.D0/XPI VPOCHA (IP,1) = XX VPOCHA (IP,2) = XT 1110 CONTINUE CALL ECCTAB(MTABLE,'ENTIER ',I ,REE0,CAR0,LOG0,Ipoin0, & 'CHPOINT ',iENT0,REE1,CAR1,LOG1,MCHPOI) ENDIF 1000 CONTINUE * IF ( NP0 .EQ. 1) THEN CALL ECCTAB(MTABLE,'ENTIER ',1 ,REE0,CAR0,LOG0,IPOIN0, & 'LISTREEL',ient0,ree1,car1,log1,mlree2) CALL ECCTAB(MTABLE,'ENTIER ',2 ,REE0,CAR0,LOG0,IPOIN0, & 'LISTREEL',ient0,ree1,car1,log1,mlree3) ENDIF CALL ECROBJ('TABLE',MTABLE) * SEGDES MTABLE SEGDES MLREE1 * SEGSUP SBORD SEGSUP SCOIN SEGSUP SMAT SEGSUP SMAT2 SEGSUP SMAI SEGSUP SPOST * RETURN END