Télécharger comcho.eso

Retour à la liste

Numérotation des lignes :

  1. C COMCHO SOURCE BP208322 16/06/08 21:15:02 8939
  2. SUBROUTINE COMCHO
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C
  6. C=======================================================================
  7. C
  8. C CALCUL DU NOMBRE DE CHOCS (syntaxe par defaut)
  9. C ou DES INDICES DE DEBUT DE CHOCS (syntaxe 'POSI')
  10. C DANS CHAQUE COURBE D'UN OBJET DE TYPE EVOLUTION.
  11. C LE RESULTAT EST UNE LISTENTI.
  12. C
  13. C SYNTAXE 1 : NCHO = COMT EVOL DECL ;
  14. C SYNTAXE 2 : ICHO = COMT 'DEBU' EVOL DECL ;
  15. C
  16. C NCHO : OBJET DE TYPE LISTENTI RESULTAT
  17. C EVOL : OBJET DE TYPE EVOLUTIO CONTENANT LES SIGNAUX A TRAITER
  18. C DECL : OBJET DE TYPE FLOTTANT % NIVEAU MAXI DES CHOCS
  19. C DEFINISSANT LE SEUIL D'ACQUISITION
  20. C NCHO : OBJET DE TYPE LISTENTI RESULTAT
  21. C
  22. C BP, 2016-05-02 : ajout syntaxe DEBU/fin + on reecrit beaucoup
  23. C
  24. C=======================================================================
  25. C
  26. -INC CCOPTIO
  27. -INC SMEVOLL
  28. -INC SMLREEL
  29. -INC SMLENTI
  30. -INC CCREEL
  31. C
  32. PARAMETER (NBMOT=2)
  33. CHARACTER*4 LISMO(NBMOT)
  34. DATA LISMO/'DEBU','FIN'/
  35. LOGICAL ZDEB,ZFIN,ZSEUIL
  36.  
  37.  
  38. C=======================================================================
  39. C LECTURE DES OBJETS EN ENTREE
  40. C=======================================================================
  41.  
  42. C EVOLUTION
  43. CALL LIROBJ('EVOLUTIO',IPEVO,1,IRET)
  44. IF(IERR.NE.0) RETURN
  45. MEVOLL=IPEVO
  46. SEGACT MEVOLL
  47. NC=IEVOLL(/1)
  48.  
  49. C SEUIL (EN %)
  50. CALL LIRREE(DECLEN,0,IDECL)
  51. IF(IERR.NE.0) RETURN
  52. IF(IDECL.EQ.0) THEN
  53. c sqrt(1.E-16)*100 ~ 1.E-6
  54. DECLEN=1.D-6
  55. ELSE
  56. CBP IF((DECLEN.LT.0.D0).OR.(DECLEN.GT.100.D0))THEN
  57. IF((DECLEN.LE.0.D0).OR.(DECLEN.GE.100.D0))THEN
  58. MOTERR(1:8)='DECLENCH'
  59. REAERR(1)=DECLEN
  60. REAERR(2)=0.D0
  61. REAERR(3)=100.D0
  62. CALL ERREUR(42)
  63. RETURN
  64. ENDIF
  65. DECLEN=MAX(DECLEN,(100.D0*XZPREC))
  66. ENDIF
  67.  
  68. C MOTS-CLES
  69. ZDEB=.FALSE.
  70. ZFIN=.FALSE.
  71. 10 IPLAC=0
  72. CALL LIRMOT (LISMO,NBMOT,IPLAC,0)
  73. IF(IERR.NE.0) RETURN
  74. IF(IPLAC.NE.0) THEN
  75. IF(IPLAC.EQ.1) ZDEB=.TRUE.
  76. IF(IPLAC.EQ.2) ZFIN=.TRUE.
  77. GOTO 10
  78. ENDIF
  79.  
  80. C AIGUILLAGE
  81. IF(ZDEB.OR.ZFIN) GOTO 200
  82.  
  83.  
  84. C=======================================================================
  85. C SYNTAXE 1
  86. C=======================================================================
  87.  
  88. JG=NC
  89. SEGINI MLENTI
  90. IPORE=MLENTI
  91.  
  92. C --- BOUCLE SUR LES COURBES ---
  93. DO 100 IC=1,NC
  94.  
  95. KEVOLL=IEVOLL(IC)
  96. SEGACT KEVOLL
  97. MLREEL=IPROGY
  98. SEGACT MLREEL
  99. L1=PROG(/1)
  100. C
  101. C CALCUL DU NIVEAU DE DECLENCHEMENT
  102. VMAX=0.D0
  103. DO 110 I=1,L1
  104. FORC=ABS(PROG(I))
  105. IF(FORC.GT.VMAX)VMAX=FORC
  106. 110 CONTINUE
  107. SEUIL=VMAX*DECLEN/100.D0
  108. IF(IIMPI.GE.1) WRITE(IOIMP,111)SEUIL
  109. 111 FORMAT(' SEUIL D''ACQUISITION : ',1PE12.5)
  110. C
  111. C COMPTE LE NOMBRE DE CHOCS
  112. NCHO=0
  113. FORC=ABS(PROG(1))
  114. ZSEUIL=FORC.GE.SEUIL
  115. DO 120 I=2,L1
  116.  
  117. FORC=ABS(PROG(I))
  118. IF(ZSEUIL) THEN
  119. * seuil deja depasse au pas precedent : on itere
  120. ZSEUIL=FORC.GE.SEUIL
  121. ELSE
  122. * on etait inferieur, et maintenant ?
  123. ZSEUIL=FORC.GE.SEUIL
  124. * on est sur un front montant
  125. IF(ZSEUIL) NCHO=NCHO+1
  126. ENDIF
  127.  
  128. 120 CONTINUE
  129. C
  130. C DESACTIVE TOUT
  131. SEGDES MLREEL
  132. SEGDES KEVOLL
  133.  
  134. C STOCKAGE DU NOMBRE DE CHOCS
  135. LECT(IC)=NCHO
  136. C
  137. 100 CONTINUE
  138. C --- FIN DE BOUCLE SUR LES COURBES ---
  139. SEGDES MEVOLL
  140. SEGDES MLENTI
  141.  
  142. C ECRITURE DU RESULTAT
  143. CALL ECROBJ('LISTENTI',IPORE)
  144. RETURN
  145.  
  146.  
  147. C=======================================================================
  148. C SYNTAXE 2
  149. C=======================================================================
  150.  
  151. 200 CONTINUE
  152.  
  153. c VERIF COMPATIBILITE
  154. IF(NC.GT.1) THEN
  155. MOTERR(1:8)='EVOLUTIO'
  156. INTERR(1:8)=IPEVO
  157. WRITE(IOIMP,*) 'ERREUR : COMT OPTION DEBUT/FIN:'
  158. CALL ERREUR(110)
  159. SEGDES MEVOLL
  160. RETURN
  161. ENDIF
  162.  
  163. IC=1
  164. KEVOLL=IEVOLL(IC)
  165. SEGACT KEVOLL
  166. MLREEL=IPROGY
  167. SEGACT MLREEL
  168. L1=PROG(/1)
  169.  
  170. JG=L1/2
  171. SEGINI MLENT1,MLENT2
  172. IPOR1=MLENT1
  173. IPOR2=MLENT2
  174. JG1=0
  175. JG2=0
  176. C
  177. C CALCUL DU NIVEAU DE DECLENCHEMENT
  178. VMAX=0.D0
  179. DO 210 I=1,L1
  180. FORC=ABS(PROG(I))
  181. IF(FORC.GT.VMAX)VMAX=FORC
  182. 210 CONTINUE
  183. SEUIL=VMAX*DECLEN/100.D0
  184. IF(IIMPI.GE.1) WRITE(IOIMP,111)SEUIL
  185. C
  186. C TROUVONS LES CHOCS
  187. NCHO=0
  188. FORC=ABS(PROG(1))
  189. ZSEUIL=FORC.GE.SEUIL
  190. DO 220 I=2,L1
  191.  
  192. FORC=ABS(PROG(I))
  193. IF(ZSEUIL) THEN
  194. * seuil deja depasse au pas precedent
  195. ZSEUIL=FORC.GE.SEUIL
  196. IF(.NOT.ZSEUIL) THEN
  197. * on est sur un front descendant
  198. JG2=JG2+1
  199. MLENT2.LECT(JG2)=I
  200. c On met 1 pour l'indice de debut si il n'existe pas
  201. c (cas du choc "a cheval" avec le bloc precedent)
  202. IF(JG1.EQ.0) THEN
  203. JG1=JG1+1
  204. MLENT1.LECT(JG1)=1
  205. ENDIF
  206. ENDIF
  207. ELSE
  208. * on etait inferieur, et maintenant ?
  209. ZSEUIL=FORC.GE.SEUIL
  210. * on est sur un front montant
  211. IF(ZSEUIL) THEN
  212. NCHO=NCHO+1
  213. JG1=JG1+1
  214. MLENT1.LECT(JG1)=I-1
  215. ENDIF
  216. ENDIF
  217.  
  218. 220 CONTINUE
  219. C on complete l'indice de fin avec L1 si il n'existe pas
  220. c (cas du choc "a cheval" avec le bloc suivant)
  221. IF(JG2.LT.JG1) THEN
  222. JG2=JG2+1
  223. MLENT2.LECT(JG2)=L1
  224. ENDIF
  225. IF(JG1.NE.JG2) WRITE(IOIMP,*) 'PB AVEC LES DIMENSIONS !'
  226. JG=JG1
  227. SEGADJ,MLENT1,MLENT2
  228. C
  229. C DESACTIVE TOUT
  230. SEGDES MLREEL
  231. SEGDES KEVOLL
  232. C
  233. SEGDES MEVOLL
  234. SEGDES MLENT1,MLENT2
  235.  
  236. C ECRITURE DU RESULTAT
  237. CALL ECROBJ('LISTENTI',IPOR2)
  238. CALL ECROBJ('LISTENTI',IPOR1)
  239. CALL ECRENT(NCHO)
  240. RETURN
  241.  
  242. END
  243.  
  244.  
  245.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales