C COMCHO SOURCE OF166741 25/02/20 21:15:40 12165 SUBROUTINE COMCHO IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C C======================================================================= C C CALCUL DU NOMBRE DE CHOCS (syntaxe par defaut) C ou DES INDICES DE DEBUT DE CHOCS (syntaxe 'POSI') C DANS CHAQUE COURBE D'UN OBJET DE TYPE EVOLUTION. C LE RESULTAT EST UNE LISTENTI. C C SYNTAXE 1 : NCHO = COMT EVOL1 (DECL) ; C SYNTAXE 2 : NCHO (LMIN) (LMAX) (LDEB/LFIN) = COMT EVOL1 (DECL) ('MINI') ('MAXI') ('DEBU'/'FIN') ; C C NCHO : OBJET DE TYPE LISTENTI RESULTAT C EVOL : OBJET DE TYPE EVOLUTIO CONTENANT LES SIGNAUX A TRAITER C DECL : OBJET DE TYPE FLOTTANT % NIVEAU MAXI DES CHOCS C DEFINISSANT LE SEUIL D'ACQUISITION C NCHO : OBJET DE TYPE LISTENTI RESULTAT C C BP, 2016-05-02 : ajout syntaxe DEBU/FIN + on reecrit beaucoup C LP, 2023-02-20 : ajout syntaxe MINI C C======================================================================= C -INC PPARAM -INC CCOPTIO -INC SMEVOLL -INC SMLREEL -INC SMLENTI -INC CCREEL POINTEUR MLREE4.MLREEL C PARAMETER (NBMOT=4) CHARACTER*4 LISMO(NBMOT) DATA LISMO/'DEBU','FIN','MAXI','MINI'/ LOGICAL ZDEB,ZFIN,ZMAX,ZSEUIL,ZMIN C======================================================================= C LECTURE DES OBJETS EN ENTREE C======================================================================= C EVOLUTION CALL LIROBJ('EVOLUTIO',IPEVO,1,IRET) IF(IERR.NE.0) RETURN MEVOLL=IPEVO SEGACT MEVOLL NC=IEVOLL(/1) C SEUIL (EN %) CALL LIRREE(DECLEN,0,IDECL) IF(IERR.NE.0) RETURN IF(IDECL.EQ.0) THEN c sqrt(1.E-16)*100 ~ 1.E-6 DECLEN=1.D-6 ELSE CBP IF((DECLEN.LT.0.D0).OR.(DECLEN.GT.100.D0))THEN IF((DECLEN.LE.0.D0).OR.(DECLEN.GE.100.D0))THEN MOTERR(1:8)='DECLENCH' REAERR(1)=DECLEN REAERR(2)=0.D0 REAERR(3)=100.D0 CALL ERREUR(42) RETURN ENDIF DECLEN=MAX(DECLEN,(100.D0*XZPREC)) ENDIF C MOTS-CLES ZDEB=.FALSE. ZFIN=.FALSE. ZMAX=.FALSE. ZMIN=.FALSE. 10 IPLAC=0 CALL LIRMOT (LISMO,NBMOT,IPLAC,0) IF(IERR.NE.0) RETURN IF(IPLAC.NE.0) THEN IF(IPLAC.EQ.1) ZDEB=.TRUE. IF(IPLAC.EQ.2) ZFIN=.TRUE. IF(IPLAC.EQ.3) ZMAX=.TRUE. IF(IPLAC.EQ.4) ZMIN=.TRUE. GOTO 10 ENDIF C AIGUILLAGE IF(ZDEB.OR.ZFIN.OR.ZMAX.OR.ZMIN) GOTO 200 C======================================================================= C SYNTAXE 1 C======================================================================= JG=NC SEGINI MLENTI IPORE=MLENTI C --- BOUCLE SUR LES COURBES --- DO 100 IC=1,NC KEVOLL=IEVOLL(IC) SEGACT KEVOLL MLREEL=IPROGY SEGACT MLREEL L1=PROG(/1) C C CALCUL DU NIVEAU DE DECLENCHEMENT VMAX=0.D0 DO 110 I=1,L1 FORC=ABS(PROG(I)) IF(FORC.GT.VMAX)VMAX=FORC 110 CONTINUE SEUIL=VMAX*DECLEN/100.D0 IF(IIMPI.GE.1) WRITE(IOIMP,111)SEUIL 111 FORMAT(' SEUIL D''ACQUISITION : ',1PE12.5) C C COMPTE LE NOMBRE DE CHOCS NCHO=0 FORC=ABS(PROG(1)) ZSEUIL=FORC.GT.SEUIL DO 120 I=2,L1 FORC=ABS(PROG(I)) IF(ZSEUIL) THEN * seuil deja depasse au pas precedent : on itere ZSEUIL=FORC.GT.SEUIL ELSE * on etait inferieur, et maintenant ? ZSEUIL=FORC.GT.SEUIL * on est sur un front montant IF(ZSEUIL) NCHO=NCHO+1 ENDIF 120 CONTINUE C C DESACTIVE TOUT SEGDES MLREEL SEGDES KEVOLL C STOCKAGE DU NOMBRE DE CHOCS LECT(IC)=NCHO C 100 CONTINUE C --- FIN DE BOUCLE SUR LES COURBES --- SEGDES MEVOLL SEGDES MLENTI C ECRITURE DU RESULTAT CALL ECROBJ('LISTENTI',IPORE) RETURN C======================================================================= C SYNTAXE 2 C======================================================================= 200 CONTINUE c VERIF COMPATIBILITE IF(NC.GT.1) THEN MOTERR(1:8)='EVOLUTIO' INTERR(1:8)=IPEVO WRITE(IOIMP,*) 'ERREUR : COMT 2eme syntaxe :' CALL ERREUR(110) SEGDES MEVOLL RETURN ENDIF IC=1 KEVOLL=IEVOLL(IC) SEGACT KEVOLL MLREEL=IPROGY SEGACT MLREEL L1=PROG(/1) c CREATION DE OBJETS DE SORTIE c OPTION DEBU/FIN JG=L1/2 SEGINI MLENT1,MLENT2 IPOR1=MLENT1 IPOR2=MLENT2 JG1=0 JG2=0 c OPTION MAXI/MINI JG=L1/2 SEGINI MLREE3,MLREE4 IPOR3=MLREE3 IPOR4=MLREE4 C C CALCUL DU NIVEAU DE DECLENCHEMENT VMAX=0.D0 DO 210 I=1,L1 FORC=ABS(PROG(I)) IF(FORC.GT.VMAX)VMAX=FORC 210 CONTINUE SEUIL=VMAX*DECLEN/100.D0 IF(IIMPI.GE.1) WRITE(IOIMP,111)SEUIL C C TROUVONS LES CHOCS NCHO=0 FORC=ABS(PROG(1)) ZSEUIL=FORC.GT.SEUIL VMAX=0.D0 VMIN=0.D0 IF(ZSEUIL) THEN VMAX=FORC ELSE VMIN=FORC ENDIF DO 220 I=2,L1 FORC=ABS(PROG(I)) IF(ZSEUIL) THEN * seuil deja depasse au pas precedent VMAX=MAX(VMAX,FORC) ZSEUIL=FORC.GT.SEUIL IF(.NOT.ZSEUIL) THEN * on est sur un front descendant JG2=JG2+1 MLENT2.LECT(JG2)=I MLREE3.PROG(JG2)=VMAX VMIN=FORC c On met 1 pour l'indice de debut si il n'existe pas c On met la valeur seuil pour le min c (cas du choc "a cheval" avec le bloc precedent) IF(JG1.EQ.0) THEN JG1=JG1+1 MLENT1.LECT(JG1)=1 MLREE4.PROG(JG1)=SEUIL ENDIF ENDIF ELSE VMIN=MIN(VMIN,FORC) * on etait inferieur, et maintenant ? ZSEUIL=FORC.GT.SEUIL * on est sur un front montant IF(ZSEUIL) THEN NCHO=NCHO+1 JG1=JG1+1 MLENT1.LECT(JG1)=I-1 MLREE4.PROG(JG1)=VMIN VMAX=FORC ENDIF ENDIF 220 CONTINUE C on complete l'indice de fin avec L1 si il n'existe pas c (cas du choc "a cheval" avec le bloc suivant) IF(JG2.LT.JG1) THEN JG2=JG2+1 MLENT2.LECT(JG2)=L1 MLREE3.PROG(JG2)=VMAX ENDIF IF(JG1.NE.JG2) WRITE(IOIMP,*) 'PB AVEC LES DIMENSIONS !' JG=JG1 SEGADJ,MLENT1,MLENT2,MLREE3,MLREE4 C C DESACTIVE TOUT SEGDES MLREEL SEGDES KEVOLL C SEGDES MEVOLL SEGDES MLENT1,MLENT2 C ECRITURE DES RESULTATS c OPTION 'FIN' IF(ZFIN) THEN CALL ECROBJ('LISTENTI',IPOR2) ELSE SEGSUP,MLENT2 ENDIF c OPTION 'DEBU' IF(ZDEB) THEN CALL ECROBJ('LISTENTI',IPOR1) ELSE SEGSUP,MLENT1 ENDIF c OPTION 'MAXI' IF(ZMAX) THEN CALL ECROBJ('LISTREEL',IPOR3) ELSE SEGSUP,MLREE3 ENDIF c OPTION 'MINI' IF(ZMIN) THEN CALL ECROBJ('LISTREEL',IPOR4) ELSE SEGSUP,MLREE4 ENDIF CALL ECRENT(NCHO) RETURN END