Télécharger comcho.eso

Retour à la liste

Numérotation des lignes :

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

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