Sources Esope | Cast3M

comcho
C COMCHO    SOURCE    BP208322  23/03/10    19:39:22     11626          
      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