C SPON SOURCE OF166741 25/02/20 21:17:40 12165 SUBROUTINE SPON IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) CHARACTER*72 TI CHARACTER*(4) CMOT C C ======================================================== C = C SPECTRES NON LINEAIRES D' OSCILLATEUR = C = C SYNTAXE : EVOL = SPON 'SIGN' EVOL1 'SPEL' EVOL2 MOTENTR= C = C 'AMOR' LAMOR 'PROP' LPROP = C = C ('COUL' COOL) SORTIE = C = C CREATION : 1990/06/15 = C PROGRAMMEUR : A.PINTO $ P.PEGON (CEC-JRC ISPRA) = C (BASE : SUBROUTINE SPO) = C 7/90 = C ======================================================== C -INC PPARAM -INC CCOPTIO -INC SMEVOLL -INC SMLREEL -INC CCGEOME *- -INC CCREEL PARAMETER (LMOT=13) CHARACTER*4 MODOM(13) CHARACTER*12 ITITY(4) DATA MODOM/'DEMA','SIGN','SPEL','AMOR', 1 'TAKE','ISOT','CINE','ELAS', & 'COUL','DEPL','VITE','ACCE','EPSE'/ DATA ITITY /'DEPL MAXIMAU','PSEUDO VITES','PSEUDO ACCEL', & 'DEFNL CUMULE'/ IPAMOR=0 IPPROP=0 ICOUL1=IDCOUL IPOEVO=0 IPSPEV=0 idema = 0 N0=-1 C C LECTURE DES OBJETS C ================== C DO 10 I=1,13 CALL LIRMOT(MODOM,LMOT,IPLAC,0) IF (IPLAC.EQ.0) GOTO 12 C 8 GOTO (20,21,22,23,24,24,24,24, & 25,26,26,26,26),IPLAC C 20 continue idema = 1 goto 10 21 CONTINUE C C TEMPS ET ACCELERATION DU SIGNAL (OBJET EVOLUTION) C CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET) IF (IRET.EQ.0) RETURN GOTO 10 C 22 CONTINUE C C SPECTRES LINEAIRES (OBJET EVOLUTION) C CALL LIROBJ ('EVOLUTIO',IPSPEV,1,IRET) IF (IRET.EQ.0) RETURN C C TYPE DES SPECTRES LINEAIRES (OBJET MOT) C ( 'DEPL', 'VITE', 'ACCE' ) C CALL LIRMOT(MODOM(10),3,ITYP,1) IF (ITYP.EQ.0) RETURN NN0=ITYP-1 GOTO 10 C 23 CONTINUE C C AMORTISSEMENT C CALL LIROBJ ('LISTREEL',IPAMOR,1,IRET) IF (IRET.EQ.0) RETURN GOTO 10 C 24 CONTINUE C C PROPRIETES C imod = iplac - 4 CALL LIROBJ ('LISTREEL',IPPROP,1,IRET) IF (IRET.EQ.0) RETURN GOTO 10 C 25 CONTINUE C C COULEURS C CALL LIRMOT (NCOUL,NBCOUL,ICOUL1,1) IF (ICOUL1.EQ.0) RETURN icoul1=icoul1-1 GOTO 10 C 26 CONTINUE C C TYPE DE LA REPONSE (SORTIE) C N0=IPLAC-10 GOTO 10 C 10 CONTINUE 12 CONTINUE C C ON VERIFIE L' EXISTENCE DES DONNES C ================================== C IF (IPOEVO.EQ.0)THEN CALL ERREUR(588) RETURN ENDIF C IF (IPSPEV.EQ.0)THEN CALL ERREUR(589) RETURN ENDIF C IF (N0.EQ.-1)THEN CALL ERREUR(590) RETURN ENDIF C IF (IPAMOR.EQ.0 ) THEN CALL ERREUR(361) RETURN ENDIF C IF (IPPROP.EQ.0 ) THEN CALL ERREUR(591) RETURN ENDIF C C ON VERIFIE LA CONSISTENCE DES DONNES C ==================================== C C AMORTISSEMENT C MLREEL=IPAMOR SEGACT MLREEL NNBAM=PROG(/1) DO 11 NBAM=1,NNBAM IF (PROG(NBAM).LT.0.OR.PROG(NBAM).GE.1) THEN MOTERR(1:8)='AMORTISS' REAERR(1)=PROG(NBAM) REAERR(2)=0. REAERR(3)=1. SEGDES MLREEL CALL ERREUR(42) RETURN ENDIF 11 CONTINUE SEGDES MLREEL C C PROPRIETES C MLREEL=IPPROP SEGACT MLREEL NNPRO=PROG(/1) IF (NNPRO.NE.5 .and.imod.eq.1) THEN INTERR(1)=5 CALL ERREUR(592) SEGDES MLREEL RETURN else if (NNPRO.NE.2 .and.imod.ne.1) then INTERR(1)=2 CALL ERREUR(592) SEGDES MLREEL RETURN else if (NNPRO.eq.2 .and.imod.ne.1) then * modele bilineaire elastoplastique ou elastique * on met n'importe quoi dans les 3 parametres qui servent à rien alfa = 0.d0 beta = 0.d0 gama = 0.d0 ENDIF IF (PROG(1).LT.1) THEN CALL ERREUR(593) SEGDES MLREEL RETURN ENDIF IF (abs(PROG(2)).GT.1. and. imod.ne.4) THEN CALL ERREUR(594) SEGDES MLREEL RETURN ENDIF IF (PROG(2).LT.0D0 .AND. IMOD.EQ.1) THEN MOTERR='TETA' CALL ERREUR(595) SEGDES MLREEL RETURN ENDIF if (imod.eq.1) then IF (PROG(3).LT.0) THEN MOTERR='ALFA' CALL ERREUR(595) SEGDES MLREEL RETURN ENDIF IF (PROG(4).LT.0) THEN MOTERR='BETA' CALL ERREUR(595) SEGDES MLREEL RETURN ENDIF IF (PROG(5).LT.0) THEN MOTERR='GAMA' CALL ERREUR(595) SEGDES MLREEL RETURN ENDIF endif C C PROPRIETES: TOUT EN ORDE C DUCT=PROG(1) TETA=PROG(2) if (imod.eq.1) then ALFA=PROG(3) BETA=PROG(4) GAMA=PROG(5) endif SEGDES MLREEL C C LE SIGNAL C MEVOLL=IPOEVO SEGACT MEVOLL KEVOLL=IEVOLL(1) SEGACT KEVOLL MLREEL=IPROGX SEGACT MLREEL ILONT=PROG(/1) TE=PROG(ILONT)-PROG(1) DTEMPO=TE/(ILONT-1.) DT=PROG(2)-PROG(1) DTT=DTEMPO-DT IF (ABS(DTT).GT.1.D-6) THEN CALL ERREUR(568) SEGDES MLREEL SEGDES KEVOLL SEGDES MEVOLL RETURN ENDIF IPT=IPROGX IPG=IPROGY SEGDES MLREEL SEGDES KEVOLL SEGDES MEVOLL C C ON RECOUPERE LE NB. DE SPECTRES C MEVOLL=IPSPEV SEGACT MEVOLL NBCOUR=IEVOLL(/1) SEGDES MEVOLL C C ON COMPARE LE NB. D'AMORTISSEMENTS AVEC LE NB. DE SPECTRES C IF (NBCOUR.NE.NNBAM) THEN CALL ERREUR(596) RETURN ENDIF C C ON COMMENCE FINALEMENT !!! C ========================== C MLREEL=IPAMOR SEGACT MLREEL N1=PROG(/1) N=N1 SEGINI MEVOLL IPEVOF=MEVOLL C MLREE3=IPT SEGACT MLREE3 LONT=MLREE3.PROG(/1) TPS=MLREE3.PROG(LONT) SEGDES MLREE3 C MEVOL1=IPSPEV SEGACT MEVOL1 C C BOUCLE SUR LES DIFFERENTS AMORTISSEMENTS C DO 100 I=1,N1 C MLREEL=IPAMOR XSI=PROG(I) C KEVOL1=MEVOL1.IEVOLL(I) SEGACT KEVOL1 MLREE1=KEVOL1.IPROGX MLREE3=KEVOL1.IPROGY SEGDES KEVOL1 SEGACT MLREE1 SEGACT MLREE3 C N2=MLREE1.PROG(/1) M=0 IAUX=0 C C C BOUCLE SUR LES FREQUENCES C JG=N2 SEGINI MLREE2 IPSPO=MLREE2 C DO 101 J=1,N2 DFREQ=MLREE1.PROG(J) AUX=1/(10.*DFREQ) IF (DT.GT.AUX) THEN IF (IAUX.EQ.0) THEN DPERIO=1/DFREQ IAUX=1 ENDIF ENDIF W=2*XPI*DFREQ W2=W*W C SPECTL=MLREE3.PROG(J) C IF (NN0.EQ.0) DISMAX=SPECTL IF (NN0.EQ.1) DISMAX=SPECTL/W IF (NN0.EQ.2) DISMAX=SPECTL/W2 C C APPEL A LA SUBROUTINE CONTENANT L'ALGORITHME C CALL INOSC2(IPT,IPG,DFREQ,XSI,RMAX,TMAX, 1 DISMAX,DUCT,ALFA,BETA,GAMA,TETA,imod,idema,xepse) C IF (TMAX.GT.TPS) M=M+1 C MLREE2=IPSPO IF (N0.EQ.0) MLREE2.PROG(J)=RMAX IF (N0.EQ.1) MLREE2.PROG(J)=W*RMAX IF (N0.EQ.2) MLREE2.PROG(J)=W2*RMAX IF (N0.EQ.3) MLREE2.PROG(J)=XEPSE 101 CONTINUE C SEGINI KEVOLL IEVOLL(I)=KEVOLL TYPX='LISTREEL' TYPY='LISTREEL' IPROGX=MLREE1 IPROGY=IPSPO NOMEVX='FREQUENCE' NOMEVY=ITITY(N0+1) NUMEVX=ICOUL1 NUMEVY='REEL' TI(1:72)=TITREE IEVTEX=TI ITYEVO='REEL' c KEVTEX=TI KEVTEX=NOMEVY SEGDES KEVOLL SEGDES MLREE2 SEGDES MLREE1 SEGDES MLREE3 100 CONTINUE C 38 FORMAT(1X,'SPON : POUR L AMORTISSEMENT',E12.5/ >1X,' IL Y A',I5,3X,'DEPLACEMENTS MAXIMAUX'/ >1X,' APRES LA FIN DU SIGNAL') 300 FORMAT(1X,'SPON : POUR L AMORTISSEMENT',E12.5/ >1X,' POUR LES FREQUENCES ( F ) >',E12.5/ >1X,' ( PERIODES ( T ) ) <',E12.5/ >1X,' LA CONDITION ( DT < 1/(10*F) ) (ACCURACY)'/ >1X,' N EST PAS VERIFIE') C SEGDES MEVOLL SEGDES MLREEL SEGDES MEVOL1 C C CALL ECROBJ ('EVOLUTIO',IPEVOF) RETURN END