C principal.f C ----------------------------------------------------------------------- C Copyright (C) 2002 Pablo Laguna C C This program is free software; you can redistribute it and/or modify it C under the terms of the GNU General Public License as published by the C Free Software Foundation; either version 2 of the License, or (at your C option) any later version. C C This program is distributed in the hope that it will be useful, but C WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU C General Public License for more details. C C You should have received a copy of the GNU General Public License along C with this program; if not, write to the Free Software Foundation, Inc., C 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. C C You may contact the author by e-mail (laguna@posta.unizar.es) or postal C mail (Dpt. Ingenieria Electrónica y Comunicaciones, Grupo de Tecnología C de las Comunicaciones (GTC), Centro Politécnico Superior. Universidad C de Zaragoza, María de Luna, 3 (Pol. Actur), Edificio A, Despacho 3.16, C 50015 Zaragoza. Spain). For updates to this software, please visit C PhysioNet (http://www.physionet.org/). C _______________________________________________________________________ c ------------------------------------------------------------- c INICIALIZA VARIABLES A CERO c ------------------------------------------------------------- subroutine inicializa_cero(iondat,iqtc,iqrspa,iqrsmw,iqrs, & iondaq,iqt) dimension iqrspa(8000),iqrsmw(8000),iqrs(8000),iondaq(8000) dimension iqt(8000),iondat(8000),iqtc(8000) do i=1,8000 iqrs(i)=0 iqrspa(i)=0 iqrsmw(i)=0 iondat(i)=0 iondaq(i)=0 iqt(i)=0 iqtc(i)=0 end do return end C ------------------------------------------------------------- C OBTIENE TODAS LAS SEQALES INTERMEDIAS PARA DETECTAR QRS C ------------------------------------------------------------- subroutine procesar(index,de_rmax,pa_rmax,pb_rmax,depb_rmax, * rq_rmax,rmw_rmax,rmd_rmax, * ifm,is,ns,ecg,ecgpa,ecgpb, * ecgder,ecgq,ecgmw,emwder,f,iret_pb,iret_pa, deri) c eSTA SUBROUTINA OBTIENE LAS SEQALES INTERMEDIAS NECESARIAS PARA c DETECTAR LOS qrsS. FILTRADAS,... c real restar, depb_rmax integer index character*12 f dimension ecg(100000),ecg_off(100000),ecgpa(100000) dimension ecgpb(100000) dimension ecgq(100000),ecgmw(100000),emwder(100000) dimension deri(100000),ecgder(100000) isf=(is+ns)*ifm call der(isf,ifm,ecg,deri) if (index.eq.0) then call normaliz_i(ifm,10,de_rmax,deri) else call normaliz_c(ifm,10,de_rmax,deri) end if c Resto la media de las "if" primeras senales al ecg para c evitar offset grandes que den fuerte respuesta en el filtro c restar=0 c do i=1,ifm c restar=restar+ecg(i) c enddo c restar=restar/ifm c do i=1,isf c ecg_off(i)=ecg(i)-restar c end do c Aplico dos veces uno de primer orden call fpa(isf,ifm,1,ecg,ECGPA,iret_pa) c call fpa(isf,ifm,1,ecg_off,ECGPA,iret_pa) c iret_pa=2*iret_pa if (index.eq.0) then call normaliz_i(ifm,10,pa_rmax,ecgpa) c write(6,*) 'pa_rmax (norma senyal pa despues i)= ', c * pa_rmax else call normaliz_c(ifm,10,pa_rmax,ECGPA) c write(6,*) 'pa_rmax (norma senyal pa despues c)= ', c * pa_rmax end if c Aplico dos veces uno de primer orden call fpb(isf,ifm,60,ECGPA,ecgpb,iret_pb) c call fpb(isf,ifm,60,ecg_off,ecgpb,iret_pb) c iret_pb=2*iret_pb if (index.eq.0) then call normaliz_i(ifm,10,pb_rmax,ecgpb) else call normaliz_c(ifm,10,pb_rmax,ECGPB) end if call der(isf,ifm,ecgpb,ecgder) if (index.eq.0) then call normaliz_i(ifm,10,depb_rmax,ecgder) else call normaliz_c(ifm,10,depb_rmax,ECGDER) end if call quad(isf,ecgder,ecgq) if (index.eq.0) then call normaliz_i(ifm,10,rq_rmax,ecgq) else call normaliz_c(ifm,10,rq_rmax,ECGQ) end if call mwint(isf,ifm,ecgq,ecgmw) if (index.eq.0) then call normaliz_i(ifm,10,rmw_rmax,ecgmw) else call normaliz_c(ifm,10,rmw_rmax,ECGMW) end if call der(isf,ifm,ecgmw,emwder) if (index.eq.0) then call normaliz_i(ifm,10,rmd_rmax,emwder) else call normaliz_c(ifm,10,rmd_rmax,EMWDER) end if return end C ------------------------------------------------------------- C DETECTA LOS QRS C ------------------------------------------------------------- subroutine detectar(index,ifm,is,ns,ecgpb,ecgder,ecgmw,emwder, * iqrspa,iqrsmw,iqrs,nqrs,f,rmax,pa_rmax,pb_rmax, & mu_an,ecg) c eSTA SUBROUTINA LLAMA A LAS QUE SON NECESARIAS PARA DETECTAR LOS c qrsS. PREVIO OBTENCION DE LAS SEQALES INTERMEDIAS c eSTAS SUBROUTINAS SE ENCUENTRAN EN EL PROGRAMA ALDETQRS.FOR c psen eS UN VECTOR QUE TIENE LOS VALORES QUE CONSIDERO COMO c PICOS DE SEQAL psen(1) ES EL PICO DE SEQAL EN ecgpb Y psen(2) c EN ecgmw, ASI MISMO psor ES EL VALOR MAS ALTO QUE CONSIDERO c RUIDO EN LAS DOS MISMAS SEQALES. c umb1,umb2 SON LOS NIVELES QUE CONSIDERO DEBE DE SOBREPASAR c LA SEQAL PARA QUE UN MAXIMO SEA UN qrs. umb1 EN UNA PRIMERA c BUSQUEDA y umb2 EN UNA SEGUNDA SI EL PRIMERO ERA DEMASIADO ALTO c iqrspa,iqrsmw,iqrs SON RESPECTIVAMENTE LAS POSICIONES DE LOS qrs c DETECTADOS EN ecgpb,ECGMW,Y LOS QUE APARECEN EN LOS DOS. dimension ecgpb(100000),ecgder(100000),ecgmw(100000) dimension emwder(100000) dimension iqrs(8000),iqrspa(8000),iqrsmw(8000),ecg(100000) character*12 f logical inv isf=ifm*(is+ns) c c index :=0 primera iteracion (hace el test de signo) c index :=1 posterior iteracion (usa el resultado del primer test para c invertir o no) variable "inv" c if (index.eq.0) then call test(ifm,ecgpb,inv) end if if (inv.eqv..true.) then call invertir(ecgpb,isf) call invertir(ecgder,isf) end if call apren1(ifm,ecgpb,ecgder,psen,psor,umb1,umb2) call apren2(ifm,ecgpb,ecgder,umb1,irrint) call detect(ifm,isf,ecgpb,ecgder,psen,psor,umb1,umb2,irrint, * nqrspa,iqrspa) c write(6,*) ' estoy aqui', ecgmw(255), ecgmw(279) call apren1(ifm,ecgmw,emwder,psen,psor,umb1,umb2) call detect(ifm,isf,ecgmw,emwder,psen,psor,umb1,umb2,irrint, * nqrsmw,iqrsmw) call confqrs(ifm,ecgpb,ecgmw,iqrspa,nqrspa,iqrsmw,nqrsmw,iqrs * ,nqrs, ecg) if (inv.eqv..true.) then call invertir(ecgpb,isf) call invertir(ecgder,isf) end if call escribir(ifm,ecgpb,iqrspa,nqrspa,ecgmw,iqrsmw,nqrsmw, * iqrs,f,rmax,pa_rmax,pb_rmax) call escribir_qrs(ifm,nqrs,iqrs,f,rmax,pa_rmax,pb_rmax,mu_an) return end C ------------------------------------------------------------- C CREA FICHEROS .QRS DONDE ESTAN LAS POSICIONES DE ESTOS C ------------------------------------------------------------- subroutine escribir_qrs(ifm,nqrs,iqrs,f,rmax,pa_rmax,pb_rmax, * mu_an) c cREA UN FICHERO *.QRS EN EL QUE ESTAN LAS POSICIOPNES DE LOS c qrs DESPUES DE SELECCIONAR LOS QUE CONSIDERO VALIDOS COMO TAL dimension iqrs(8000) character*12 f write(21,10) f 10 format(3x,'n',2x,'posicion',2x,a7) write(21,*) write(21,11) ifm 11 format(3x,'frecuencia de muestreo =',i4) write(21,*) ' posicion en milisegundos' write(21,*) do i=1,nqrs anum=(iqrs(i)+mu_an)*1000/ifm write(21,15) i,anum 15 format(2x,i4,4x,F12.0) end do write(21,1) rmax 1 format(1x,'RMAX =',F12.3,' Factor d''escala senyal') write(21,2) pa_rmax 2 format(1x,'PA_RMAX =',F12.3,' Factor d''escala senyal * passa_alt') write(21,3) pb_rmax 3 format(1x,'PB_RMAX =',F12.3,' Factor d''escala senyal * passa_baix') return end C ------------------------------------------------------------- C CREA FICHEROS .QPM DONDE ESTAN LOS QRS DE Pb Y MW C ------------------------------------------------------------- subroutine escribir(ifm,ecgpb,iqrspa,nqrspa,ecgmw,iqrsmw, * nqrsmw,iqrs,f,rmax,pa_rmax,pb_rmax) c eSCRIBO EN UN FICHERO *.qpm LAS POSICIONES DEL qrs. DETECTADOS c EN LAS DOS SEQALES EN LAS QUE MIRO. dimension ecgpb(100000),ecgmw(100000),iqrspa(8000) dimension iqrsmw(8000) dimension iqrs(8000) character*12 f nmax=nqrspa if (nqrsmw.gt.nmax) nmax=nqrsmw write(20,10) f 10 format(3x,'n',2x,'posicion pa',2x,'intervalo',2x,'valor', * 4x,'posicion mw',2x,'intervalo',3x,'valor',7x,'retar', * ' n',4x,'posi-qrs',' paciente = ',a7) write(20,*) write(20,11) ifm 11 format(3x,'frecuencia de muestreo =',i4) write(20,*) do i=1,nmax write(20,15) i,iqrspa(i),iqrspa(i+1)-iqrspa(i), * ecgpb(iqrspa(i)),iqrsmw(i),iqrsmw(i+1)-iqrsmw(i), * ecgmw(iqrsmw(i)),iqrsmw(i)-iqrspa(i),i,iqrs(i) 15 format(2x,i4,4x,i9,6x,i9,4x,f9.3,5x,i9,6x,i9,4x,f9.3,4x,i9,5x, * i4,5x,i9) end do write(20,1) rmax 1 format(1x,'RMAX =',F12.3,' Factor d''escala senyal') write(20,2) pa_rmax 2 format(1x,'PA_RMAX =',F12.3,' Factor d''escala senyal * passa_alt') write(20,3) pb_rmax 3 format(1x,'PB_RMAX =',F12.3,' Factor d''escala senyal * passa_baix') return end C ------------------------------------------------------------- C DEFINE EL COMIENZO Y FIN DE LA ONDA Q Y T RESPECTIVAMENTE C ------------------------------------------------------------- subroutine calcula_qt(ecgpb,ecgder,iqrs,iondaq,iondat, & ifm,nqrs,f,iqt,iqtc) C BUSCA Y DEFINE EL PRINCIPIO Y FIN DE Q Y T SEGUN DISTINTOS C ALGORITMOS dimension ecgpb(100000),ecgder(100000),iqrs(8000) dimension iondaq(8000) dimension iondat(8000),iqt(8000),iqtc(8000) character*12 f write(6,*) ' que algoritmo quieres usar?' write(6,*) ' 1-fuerte inflexion' write(6,*) ' 2-umbral de la derivada' 5 write(6,10) 10 format('$ OPCION:') read(5,*,err=5) iask call int_qt(ecgpb,ecgder,iqrs,iondaq,iondat,ifm,nqrs, & iqt,iqtc,iask) call escribe_qt(f//'.qt',ifm,iqt,nqrs) call escribe_qt(f//'.qtc',ifm,iqtc,nqrs) return end C ------------------------------------------------------------- C CREA FICHEROS .prn PARA IMPRIMIR POR LA PRINTRONIX C ------------------------------------------------------------- subroutine impregraf(f,ifm,ecg,ecgpa,ecgpb,ecgder,ecgq,ecgmw, & emwder,elba,ecglb,iqrs,iqrspa,iqrsmw,ipbeg,ippos1, & ippos2,ipend, iqbeg, iqpos, ispos, isend, itbeg, itpos, & itend, derfi, irrpos, iqend, isbeg, basel, itpos2) c eSTA SUBROUTINA CREA UN FICHERO IMPRIMIBLE POR UNA IMPRESORA c pRINTRONIX. QUE REPRESENTA LAS SEQALES SELECCIONADAS, HACIENDO c DE LA LIBRERIA DE RUTINAS GRAFICAS graflpt.Y DE RUTINAS DEL c PROGRAMA GRAF.FOR. eL FICHERO QUE CREA SE LLAMA *.prn c dimension ecg(100000),ecgpa(100000),ecgpb(100000) dimension ecgder(100000) dimension ecgq(100000),ecgmw(100000),emwder(100000) dimension der1f(100000) dimension elba(100000),ecglb(100000),ecg_off(100000) dimension iqrs(8000),iondat(8000),iondaq(8000) dimension iqrspa(8000) dimension der2(100000),derfi(100000),iqrsmw(8000) dimension ipbeg(8000),ippos1(8000),ippos2(8000) dimension ipend(8000) dimension iqbeg(8000),itpos(8000) dimension iqpos(8000),ispos(8000),isend(8000),itbeg(8000) dimension itend(8000),irrpos(8000),iqend(8000),isbeg(8000) dimension basel(8000),itpos2(8000) character*12 f character*1 siono, siono2 iask=2 call pedir(is,ns) nptssr=is*ifm npts=ns*ifm do while (iask.ne.0) write(6,*) write(6,*)'se crea un fichero (sen.prn) de cada seqal' write(6,*)'2 ecg 3 ecgpa 4 ecgpb 5 ecgder' write(6,*)'6 ecgq 7 ecgmw 8 emwder 9 derfil' write(6,*)'1 der2 10 lba 11 ecglb 0 ninguna' 15 write(6,20) 20 format('$ OPCION:') read(5,*,err=15) iask if (iask.ne.0) then 30 write (6,40) 40 format(/'$ Hi vols les marques dels punts', & ' significatius ? [s/n]') read (5,'(A)',err=30) siono 42 write (6,45) 45 format(/'$ Hi vols les marques de la lmnia de base? [s/n]') read (5,'(A)',err=42) siono2 end if if (iask.eq.2) then call sacagraf(f(1:lnblnk(f))//'_ecg','s',ecg,nptssr,npts, & ifm,izero,iaskt,escy) if (siono2.eq.'s') then call l_saca_basel(basel, iqrs, npts, nptssr, izero, escy) end if else if (iask.eq.3) then call sacagraf(f(1:lnblnk(f))//'_pa','s',ecgpa,nptssr,npts, & ifm,izero,iaskt,aux) else if (iask.eq.4) then call sacagraf(f(1:lnblnk(f))//'_pb','s',ecgpb,nptssr,npts, & ifm,izero,iaskt,aux) else if (iask.eq.5) then call sacagraf(f(1:lnblnk(f))//'_der','s',ecgder,nptssr,npts, & ifm,izero,iaskt,aux) else if (iask.eq.6) then call sacagraf(f(1:lnblnk(f))//'_q','s',ecgq,nptssr,npts, & ifm,izero,iaskt,aux) else if (iask.eq.7) then call sacagraf(f(1:lnblnk(f))//'_mw','s',ecgmw,nptssr,npts, & ifm,izero,iaskt,aux) call marca(iqrsmw,npts,nptssr,150,175,iaskt) else if (iask.eq.8) then call sacagraf(f(1:lnblnk(f))//'_mder','s',emwder,nptssr,npts, & ifm,izero,iaskt,aux) else if (iask.eq.9) then c call fpb(ifm*(is+ns),ifm,30,ecgder,der1f,iret_pb) c call normaliz(ifm,10,der1f) call sacagraf(f(1:lnblnk(f))//'_dfi','s',derfi,nptssr,npts, & ifm,izero,iaskt,aux) else if (iask.eq.10) then call sacagraf(f(1:lnblnk(f))//'_lba','s',elba,nptssr,npts, & ifm,izero,iaskt,aux) else if(iask.eq.1) then call fpb(ifm*(is+ns),ifm,30,ecgder,der1f,iret_pb) c call fpb(ifm*(is+ns),ifm,30,ecg_off,der1f,iret_pb) c iret_pb=2*iret_pb call der(ifm*(is+ns),ifm,der1f,der2) call normaliz(ifm,10,der2) call sacagraf(f(1:lnblnk(f))//'_der2','s',der2,nptssr,npts, & ifm,izero,iaskt,aux) else if (iask.eq.11) then call sacagraf(f(1:lnblnk(f))//'_ecglb','s',ecglb,nptssr,npts, & ifm,izero,iaskt, aux) end if c Les marques dels punts significatius no cal que es representin si no es c vol if (siono.eq.'s') then call marca(iqrs,npts,nptssr,150,175,iaskt) call marca(irrpos,npts,nptssr,150,175,iaskt) call marca(ipbeg,npts,nptssr,izero+150,izero+50,iaskt) call marca(ippos1,npts,nptssr,izero+50,izero+25,iaskt) call marca(ippos2,npts,nptssr,izero+50,izero+25,iaskt) call marca(ipend,npts,nptssr,izero+150,izero+50,iaskt) call marca(iqbeg,npts,nptssr,izero+150,izero+50,iaskt) call marca(iqpos,npts,nptssr,izero+175,izero+150,iaskt) c call marca(iqend,npts,nptssr,izero+175,izero+150,iaskt) c call marca(isbeg,npts,nptssr,izero+175,izero+150,iaskt) call marca(ispos,npts,nptssr,izero+175,izero+150,iaskt) call marca(isend,npts,nptssr,izero+150,izero+50,iaskt) call marca(itbeg,npts,nptssr,izero+150,izero+50,iaskt) call marca(itpos,npts,nptssr,izero+175,izero+150,iaskt) call marca(itpos2,npts,nptssr,izero+50,izero+25,iaskt) call marca(itend,npts,nptssr,izero+150,izero+50,iaskt) end if c c CERRAR EL FICHERO if (iask.eq.0) return call l_prinplot(1,1,2,2) CLOSE(2) end do return end C ------------------------------------------------------------- C REPRESENTA POR PANTALLA VT240 C ------------------------------------------------------------- subroutine pantagrafold(ifm,ecg,ecgpa,ecgpb,ecgder,ecgq,ecgmw, & emwder,elba,iqrspa,iqrsmw,iqrs,ipbeg, ippos1, ippos2, ipend, & iqbeg, iqpos, ispos, isend, itbeg, itpos, itend, & derfi, irrpos, iqend, isbeg, is, ns,kon) c eSTA SUBROUTINA REPRESENTA POR PANTALLA vt240 LAS SEQALES ELECTRO- c CARDIOGRAFICAS, CON SU ESCALADO Y LOS qrs DETECTADOS EN ecgpb Y c ecgmw ASI COMO AQUELLOS QUE SELECCIONO COMO VALIDOS, PONIENDOLES c UNA DOBLE MARCA. uSO TAMBIEN RUTINAS DEL PROGRAMA GRAF.FOR c dimension ecg(100000),ecgpa(100000),ecgpb(100000) dimension ecgder(100000) dimension ecgq(100000),ecgmw(100000),emwder(100000),iqrs(8000) dimension elba(100000) dimension iqrspa(8000),iqrsmw(8000),iondaq(8000),iondat(8000) dimension ecgder2(100000), derfi(100000) dimension ipbeg(8000),ippos1(8000),ippos2(8000),ipend(8000) dimension iqbeg(8000) dimension iqpos(8000),ispos(8000),isend(8000),itbeg(8000) dimension itpos(8000) dimension itend(8000), irrpos(8000), iqend(8000), isbeg(8000) character*1 espera if (kon.gt.0) then call salgraf call pedir(is,ns) call inicializa end if c representacion por pantalla call inicializa call dibujaold(ifm,ecg,is,ns,100,' ecg',80.) call pintqrs(iqrs,ifm,is,ns,30,15) c call pintqrs(irrpos,ifm,is,ns,50,10) c call pintqrs(ipbeg,ifm,is,ns,125,50) c call pintqrs(ippos1,ifm,is,ns,75,10) c call pintqrs(ippos2,ifm,is,ns,75,10) c call pintqrs(ipend,ifm,is,ns,125,50) c call pintqrs(iqbeg,ifm,is,ns,125,50) c call pintqrs(iqpos,ifm,is,ns,150,15) c call pintqrs(iqend,ifm,is,ns,135,15) c call pintqrs(isbeg,ifm,is,ns,135,15) c call pintqrs(ispos,ifm,is,ns,150,15) c call pintqrs(isend,ifm,is,ns,125,50) c call pintqrs(itbeg,ifm,is,ns,125,50) c call pintqrs(itpos,ifm,is,ns,75,10) c call pintqrs(itpos,ifm,is,ns,135,10) c call pintqrs(itend,ifm,is,ns,125,50) c call dibujaold(ifm,ecgpa,is,ns,190,'ecgpa',3.) call dibujaold(ifm,ECGPB,is,ns,275,'ECGPB',6.0) call pintqrs(iqrspa,ifm,is,ns,225,15) c call pintqrs(irrpos,ifm,is,ns,225,15) c call pintqrs(ipbeg,ifm,is,ns,300,50) c call pintqrs(ippos1,ifm,is,ns,250,10) c call pintqrs(ippos2,ifm,is,ns,250,10) c call pintqrs(ipend,ifm,is,ns,300,50) c call pintqrs(iqbeg,ifm,is,ns,300,50) c call pintqrs(iqpos,ifm,is,ns,325,15) c call pintqrs(iqend,ifm,is,ns,310,15) c call pintqrs(isbeg,ifm,is,ns,310,15) c call pintqrs(ispos,ifm,is,ns,325,15) c call pintqrs(isend,ifm,is,ns,300,50) c call pintqrs(itbeg,ifm,is,ns,300,50) c call pintqrs(itpos,ifm,is,ns,250,10) c call pintqrs(itpos,ifm,is,ns,310,10) c call pintqrs(itend,ifm,is,ns,300,50) call dibujaold(ifm,ecgmw,is,ns,450,'ecgmw',6.0) call pintqrs(iqrsmw,ifm,is,ns,380,15) c call dibujaold(ifm,derfi,is,ns,450,'ecgder',6.0) c call pintqrs(iqrs,ifm,is,ns,400,15) c call pintqrs(irrpos,ifm,is,ns,400,15) c call pintqrs(ipbeg,ifm,is,ns,475,50) c call pintqrs(ippos1,ifm,is,ns,425,10) c call pintqrs(ippos2,ifm,is,ns,425,10) c call pintqrs(ipend,ifm,is,ns,475,50) c call pintqrs(iqbeg,ifm,is,ns,475,50) c call pintqrs(iqpos,ifm,is,ns,500,15) c call pintqrs(iqend,ifm,is,ns,485,15) c call pintqrs(isbeg,ifm,is,ns,485,15) c call pintqrs(ispos,ifm,is,ns,500,15) c call pintqrs(isend,ifm,is,ns,475,50) c call pintqrs(itbeg,ifm,is,ns,475,50) c call pintqrs(itpos,ifm,is,ns,425,10) c call pintqrs(itpos,ifm,is,ns,485,10) c call pintqrs(itend,ifm,is,ns,475,50) c call der(if*(is+ns),ifm,ecgder,ecgder2) c call normaliz(ifm,10,ecgder2) c call dibujaold(ifm,ecgder2,is,ns,360,'ecgd2',30.) call salgraf 5 write(6,10) 10 format('$ [CR]:') read(5,'(a)',err=5) espera return end C ------------------------------------------------------------- C REPRESENTA POR PANTALLA VT240 C ------------------------------------------------------------- subroutine pantagraf(ifm,ecg,ecgpa,ecgpb,ecgder,ecgq,ecgmw, & emwder,elba,ecglb,iqrspa,iqrsmw,iqrs,ipbeg, ippos1, ippos2, & ipend,iqbeg, iqpos, ispos, isend, itbeg, itpos, itend, & derfi,irrpos,iqend,isbeg,nqrs,basel,deri,itpos2,i_base) c eSTA SUBROUTINA REPRESENTA POR PANTALLA vt240 LAS SEQALES ELECTRO- c CARDIOGRAFICAS, CON SU ESCALADO Y LOS qrs DETECTADOS EN ecgpb Y c ecgmw ASI COMO AQUELLOS QUE SELECCIONO COMO VALIDOS, PONIENDOLES c UNA DOBLE MARCA. uSO TAMBIEN RUTINAS DEL PROGRAMA GRAF.FOR c dimension ecg(100000),ecgpa(100000),ecgpb(100000) dimension ecgder(100000) dimension ecgq(100000),ecgmw(100000),emwder(100000),iqrs(8000) dimension elba(100000),ecglb(100000),i_base(8000) dimension iqrspa(8000),iqrsmw(8000),iondaq(8000),iondat(8000) dimension ecgder2(100000),derfi(100000),deri(100000) dimension ipbeg(8000),ippos1(8000),ippos2(8000),ipend(8000) dimension iqbeg(8000),basel(8000) dimension iqpos(8000),ispos(8000),isend(8000),itbeg(8000) dimension itpos(8000) dimension itend(8000),irrpos(8000), iqend(8000), isbeg(8000) dimension auxba(8000),itpos2(8000) call pedir(is,ns) c iy=3*fesc*33 jgain=200 iy=240 k=1 kon=0 samp=1000./ifm call baseline(nqrs,ippos1,ecg,basel,samp,ipbeg,ipend,iqbeg, & isend,i_base) do i=1,nqrs auxba(i)=0 end do do while(k.ne.0) write(6,30) 30 format (///,t28,'OPCIONS GRAFIQUES',//) write(6,35) 35 format ( & t10,'1 ecg 5 derfi 9 ecg, ecgpb, derfi' &/t10,'2 ecgpa 6 lba 10 ecg, ecgpb, lba' &/t10,'3 ecgpb 7 deri 11 ecg, ecgpb, ecgmw' &/t10,'4 ecgder 8 ecglb'// & t10,' 0 sortir') 39 write(6,40) 40 format(//,'$',t20,'OPCIO: ') read(5,41,err=39) k 41 format(I2) if (k.eq.0) return if ((k.ne.9).and.(k.ne.10).and.(k.ne.11)) then write(6,10) 10 format(2x,/,'$ Introdueix factor de escala [1.]: ') read(5,*,err=15) fesc c 11 format(f3.1) 15 if (fesc.eq.0.0) fesc=1. end if c representacion por pantalla call inicializa if(k.eq.1) then call dibuja(ifm,ecg,is,ns,iy,' ecg',fesc,ipbeg,ippos1,ipend, & iqbeg,iqpos,iqend,iqrs,isbeg,ispos,irrpos,isend,itbeg, & itpos,itend, nqrs,basel,itpos2) else if(k.eq.2)then call dibuja(ifm,ecgpa,is,ns,iy,'ecgpa',fesc,ipbeg,ippos1,ipend, & iqbeg,iqpos,iqend,iqrs,isbeg,ispos,irrpos,isend,itbeg, & itpos,itend, nqrs,auxba,itpos2) else if(k.eq.3)then call dibuja(ifm,ecgpb,is,ns,iy,'ecgpb',fesc,ipbeg,ippos1,ipend, & iqbeg,iqpos,iqend,iqrs,isbeg,ispos,irrpos,isend,itbeg, & itpos,itend, nqrs,auxba,itpos2) else if(k.eq.4)then call dibuja(ifm,ecgder,is,ns,iy,'ecgde',fesc,ipbeg,ippos1,ipend, & iqbeg,iqpos,iqend,iqrs,isbeg,ispos,irrpos,isend,itbeg, & itpos,itend, nqrs,auxba,itpos2) else if(k.eq.5)then call dibuja(ifm,derfi,is,ns,iy,'derfi',fesc,ipbeg,ippos1,ipend, & iqbeg,iqpos,iqend,iqrs,isbeg,ispos,irrpos,isend,itbeg, & itpos,itend, nqrs,auxba,itpos2) else if(k.eq.6)then call dibuja(ifm,elba,is,ns,iy,'lin_base',fesc,ipbeg,ippos1,ipend, & iqbeg,iqpos,iqend,iqrs,isbeg,ispos,irrpos,isend,itbeg, & itpos,itend, nqrs,auxba,itpos2) else if(k.eq.7)then call dibuja(ifm,deri,is,ns,iy,'deri',fesc,ipbeg,ippos1,ipend, & iqbeg,iqpos,iqend,iqrs,isbeg,ispos,irrpos,isend,itbeg, & itpos,itend, nqrs,auxba,itpos2) else if(k.eq.8)then call dibuja(ifm,ecglb,is,ns,iy,'ecg-lb',fesc,ipbeg,ippos1,ipend, & iqbeg,iqpos,iqend,iqrs,isbeg,ispos,irrpos,isend,itbeg, & itpos,itend, nqrs,auxba,itpos2) else if(k.eq.9) then if (kon.gt.0) then call salgraf call pedir(is,ns) call inicializa end if c representacion por pantalla call inicializa call dibujaold(ifm,ecg,is,ns,100,'ecg',45.0) call pintqrs(iqrs,ifm,is,ns,30,15) call dibujaold(ifm,ECGpb,is,ns,250,'ECGpb',7.0) call dibujaold(ifm,derfi,is,ns,400,'derfi',30.0) call pintqrs(irrpos,ifm,is,ns,50,10) call pintqrs(ipbeg,ifm,is,ns,125,50) call pintqrs(ippos1,ifm,is,ns,75,10) call pintqrs(ipend,ifm,is,ns,125,50) call pintqrs(iqbeg,ifm,is,ns,125,50) call pintqrs(iqpos,ifm,is,ns,150,15) call pintqrs(iqend,ifm,is,ns,135,15) call pintqrs(isbeg,ifm,is,ns,135,15) call pintqrs(ispos,ifm,is,ns,150,15) call pintqrs(isend,ifm,is,ns,125,50) call pintqrs(itbeg,ifm,is,ns,125,50) call pintqrs(itpos,ifm,is,ns,75,10) call pintqrs(itpos,ifm,is,ns,135,10) call pintqrs(itend,ifm,is,ns,125,50) call salgraf 97 write(6,98) 98 format('$ [CR]:') read(5,'(a)',err=97) espera else if(k.eq.10) then if (kon.gt.0) then call salgraf call pedir(is,ns) call inicializa end if c representacion por pantalla call inicializa call dibujaold(ifm,ecg,is,ns,100,'ecg',45.0) call pintqrs(iqrs,ifm,is,ns,30,15) call dibujaold(ifm,elba,is,ns,250,'lin_b',45.0) call dibujaold(ifm,ECGpb,is,ns,400,'ECGpb',7.0) call salgraf 99 write(6,100) 100 format('$ [CR]:') read(5,'(a)',err=99) espera else if(k.eq.11) then if (kon.gt.0) then call salgraf call pedir(is,ns) call inicializa end if c representacion por pantalla call inicializa call dibujaold(ifm,ecg,is,ns,100,' ecg',45.) call pintqrs(iqrs,ifm,is,ns,30,15) call dibujaold(ifm,ECGPB,is,ns,275,'ECGPB',6.0) call pintqrs(iqrspa,ifm,is,ns,225,15) call dibujaold(ifm,ecgmw,is,ns,450,'ecgmw',6.0) call pintqrs(iqrsmw,ifm,is,ns,380,15) call salgraf 110 write(6,120) 120 format('$ [CR]:') read(5,'(a)',err=110) espera end if non=kon+1 end do return end C ------------------------------------------------------------- C TOMO EL SEGUNDO INCIAL Y EL NUMERO DE SEG. A PROCESAR C ------------------------------------------------------------- subroutine pedir(is,ns) c SOLICITA EN EL PUNTO QUE SE LLAMA EL SEGUNDO INICIAL Y EL NUMERO c DE SEGUNDOS CON LOS QUE QIERO TRABAJAR. write(6,*) 5 write(6,10) 10 format('$ segundo inicial is= ') read(5,*,err=5) is write(6,*) 15 write(6,20) 20 format('$ numero de segundos ns= ') read(5,*,err=15) ns return end C ------------------------------------------------------------- C REPRESENTA LA FUNCION DE TRANFERENCIA DE LOS FILTROS C ------------------------------------------------------------- subroutine funtrans(ifm,fcb,fca) dimension fpb(100000),fpa(100000),der2(100000),fpt(100000) character*9 blancos character*1 ask C rEPRESENTA Y CREA UN FICHERO SI SE QUIERE DE LAS FUNCIONES DE C TRANSFERENCIA DEL FILTRO PASO BANDA Y DE LA DERIVADA c fcb eS LA FREC. DE CORTE DEL fpb, fca DEL fpa, flr ES LA MAYOR c FRECUENCIA REPRESENTADA c lb eS EL NUMERO DE CEROS DEL fpb. Y la DEL fpa. lb=nint(ifm/fcb) la=nint(ifm/fca) DO I=1,1500 c DO I=1,1000 FPB(I)=PB(I,lb,ifm) c FPA(I)=la-PB1(I,la,ifm) FPA(I)=(la*la)-PB(I,la,ifm) FPT(I)=FPB(I)*FPA(I) DER2(I)=(ifm/4)*(SIN(4*I*3.1416/10/ifm)+2*SIN(2*3.1416*I/10/ifm)) END DO CALL NORMALIZ(1000,50,FPB) CALL NORMALIZ(1000,50,FPA) c CALL NORMALIZ(1000,50,DER2) CALL NORMALIZ(1500,50,DER2) call normaliz(1000,50,fpt) call inicializa call dibujaold(100,fpt,0,10,220,'hz/10',3.) call dibujaold(100,der2,0,10,440,'der ',3.) call salgraf write(6,5) 5 format('$ Quieres copia por impresora? [n]: ') read(5,'(A)') ask if (ask.eq.'s'.or.ask.eq.'S') then write(6,*) write(6,*) '1 printronix 2 laser_writer ' 10 write(6,15) 15 format('$ OPCION:') read(5,*,err=10) iaskt iask=1 do while (iask.ne.0) write(6,*) write(6,*) 'quieres crear un fichero para impresora ?' write(6,*) '1 fil-pb 2 fil-pa 3 deriv' write(6,*) '4 fil-pt 0 salir' 20 write(6,25) 25 format('$ OPCION:') read(5,*,err=20) iask BLANCOS=' ' if (iask.eq.1) then c call sacagraf(' fil_pb','s',fpb,0,1000,10, c & izero,iaskt, aux) call sacagraf(' fil_pb','s',fpb,0,150,10, & izero,iaskt, aux) else if (iask.eq.2) then c call sacagraf(' fil_pa','s',fpa,0,1000,10, c & izero,iaskt, aux) call sacagraf(' fil_pa','s',fpa,0,150,10, & izero,iaskt, aux) else if (iask.eq.3) then c call sacagraf(' deriv','s',der2,0,1000,10, c & izero,iaskt, aux) call sacagraf(' deriv','s',der2,0,1500,10, & izero,iaskt, aux) else if (iask.eq.4) then call sacagraf(' fil_pt','s',fpt,0,1000,10, & izero,iaskt, aux) end if if (iask.eq.0) return if (iaskt.eq.1) then C call prinplot(1,1,2,2) else call l_prinplot(1,1,2,2) end if close(2) end do end if return end c --------------------------------------------------------------- real function pb(l,n,ifm) c ES UNA FUNCION QUE CALCULA EL VALOR DE LA FUNCION DE TRANSFERENCIA c DEL FILTRO PASO BAJO PARA FRECUENCIA DE MUESTREO ifm, NUMERO DE CEROS c n, y l FRECUENCIA DE LA SEQAL, de segundo orden r=sin(3.1416*l/10/ifm) if (r.Eq.0.) then pb=n**2 else pb=(sin(n*3.1416*l/10/ifm))**2/(sin(3.1416*l/10/ifm))**2 end if return end c --------------------------------------------------------------- real function pb1(l,n,ifm) c eS UNA FUNCION QUE CALCULA EL VALOR DE LA FUNCION DE TRANSFERENCIA c DEL FILTRO PASO BAJO PARA FRECUENCIA DE MUESTREO ifm, NUMERO DE CEROS c n, y l FRECUENCIA DE LA SEQAL, de primer orden r=sin(3.1416*l/10/ifm) if (r.Eq.0.) then pb1=n else pb1=abs( sin(n*3.1416*l/10/ifm) / sin(3.1416*l/10/ifm) ) end if return end C ----------------------------------------------------------------- C RUTINA PARA REPRESENTAR QT C ---------------------------------------------------------------- subroutine representar_qt(ifm,is,ns,iqrs,iqt,iqtc,nqrs,f) dimension iqrs(8000),iqt(8000),iqtc(8000) character*1 ask character*12 f call grafica_qt(ifm,is,ns,iqrs,iqt,iqtc) write(6,5) 5 format('$ [CR]:') read(5,'(A)') espera write(6,*) write(6,10) 10 format('$ Quieres copia para impresora? [n]: ') read(5,'(A)') ask if (ask.eq.'s'.or.ask.eq.'S') then write(6,*) write(6,*) '1 impresora 2 laser_writer' 15 write(6,20) 20 format('$ OPCION:') read(5,*,err=15) iask if (iask.eq.2) then call l_grafica_qt(f//'_qt',ifm,is,ns,iqrs,iqt,nqrs) call l_grafica_qt(f//'_qtc',ifm,is,ns,iqrs,iqtc,nqrs) else call p_grafica_qt(f//'_qt',ifm,is,ns,iqrs,iqt,nqrs) call p_grafica_qt(f//'_qtc',ifm,is,ns,iqrs,iqtc,nqrs) end if end if return end C ---------------------------------------------------------------- C SACAGRAF BIEN POR LA PRINTRONIX BIEN POR LA LASER C ---------------------------------------------------------------- subroutine sacagraf(titgen,lizer,sen,nptssr,npts,ifm, & izero,iaskt,escy) character*17 titgen character*1 lizer dimension sen(100000) integer*4 npts C C iaskt VALE 1 PARA PRINTRONIX Y 2 PARA LASER call sacalaser(titgen,lizer,sen,nptssr,npts,ifm,izero, & escy) return end C --------------------------------------------------------------- C MARCA SOBRE LOS GRAFICOS C -------------------------------------------------------------- subroutine marca(ipos,npts,nptssr,iyi,iyf,iaskt) dimension ipos(8000) if (iaskt.eq.1) then call pinta_marca(ipos,npts,nptssr,iyi,iyf) else call l_pinta_marca(ipos,npts,nptssr,iyi,iyf) end if return end c ------------------------------------------------------------- c Inicializa ventana en el QRS c ------------------------------------------------------------- subroutine inicializa_ven_qrs(f,f1,f2,f3,npos_r,ior, & ianchs_r,ianchp_r) character*12 f,f1,f2,f3 write(6,*) 1 write(6,2) 2 format('$ Especifica modificacio punt QRS: ') read(5,*,err=1) npos_r ior=3 write(6,*) do while (ior.ne.0.and.ior.ne.1.and.ior.ne.2) write(6,*) 'Selecciona el filtrat realitzat al senyal: ' write(6,*) ' 0 Filtre passa alt (fo = 1 Hz)' write(6,*) ' 1 Filtre passa banda (fo = 60 Hz)' write(6,*) ' 2 ECG original ' 5 write(6,6) 6 format('$ OPCION:') read(5,*,err=5) ior end do if (ior.eq.0) then open(unit=7,file=f(1:lnblnk(f))//'fin_pa.qrs') else if (ior.eq.1) then open(unit=7,file=f(1:lnblnk(f))//'fin_pb.qrs') else if (ior.eq.2) then open(unit=7,file=f(1:lnblnk(f))//'fin.qrs') end if c open(unit=17,file=f1(1:lnblnk(f1))//'fin.qrs') C open(unit=27,file=f2(1:lnblnk(f2))//'fin.qrs') C open(unit=37,file=f3(1:lnblnk(f3))//'fin.qrs') write(6,*) 10 write(6,11) 11 format('$ anchura ventana sincronismo en R (muestras): ') read(5,*,err=10) ianchs_r 12 write(6,13) 13 format('$ anchura ventana promediado en R (muestras): ') read(5,*,err=12) ianchp_r return end c ------------------------------------------------------------- c Inicializa ventana en la onda P c ------------------------------------------------------------- subroutine inicializa_ven_p(f,f1,f2,f3,npos_p,iop,ianchs_p, & ianchp_p) character*12 f,f1,f2,f3 write(6,*) 2 write(6,3) 3 format('$ selecciona distancia P-R: ') read(5,*,err=2) npos_p iop=3 write(6,*) do while (iop.ne.0.and.iop.ne.1.and.iop.ne.2) write(6,*) 'Selecciona el filtrat realitzat al senyal: ' write(6,*) ' 0 Filtre passa alt (fo = 1 Hz)' write(6,*) ' 1 Filtre passa banda (fo = 60 Hz)' write(6,*) ' 2 ECG original ' 5 write(6,6) 6 format('$ OPCION:') read(5,*,err=5) iop end do if (iop.eq.0) then open(unit=8,file=f(1:lnblnk(f))//'fin_pa.p') else if (iop.eq.1) then open(unit=8,file=f(1:lnblnk(f))//'fin_pb.p') else if (iop.eq.2) then open(unit=8,file=f(1:lnblnk(f))//'fin.p') end if c open(unit=18,file=f1//'fin.p') C open(unit=28,file=f2(1:lnblnk(f2))//'fin.p') C open(unit=38,file=f3(1:lnblnk(f3))//'fin.p') write(6,*) 9 write(6,10) 10 format('$ anchura ventana sincronismo en P (muestras): ') read(5,*,err=9) ianchs_p 14 write(6,15) 15 format('$ anchura ventana promediado en P (muestras): ') read(5,*,err=14) ianchp_p return end c ------------------------------------------------------------- c Inicializa ventana en la onda T c ------------------------------------------------------------- subroutine inicializa_ven_t(f,f1,f2,f3,npos_t,iot,ianchs_t, & ianchp_t) character*12 f,f1,f2,f3 write(6,*) 2 write(6,3) 3 format('$ selecciona distancia T-R: ') read(5,*,err=2) npos_t iot=3 write(6,*) do while (iot.ne.0.and.iot.ne.1.and.iot.ne.2) write(6,*) 'Selecciona el filtrat realitzat al senyal: ' write(6,*) ' 0 Filtre passa alt (fo = 1 Hz)' write(6,*) ' 1 Filtre passa banda (fo = 60 Hz)' write(6,*) ' 2 ECG original ' 5 write(6,6) 6 format('$ OPCION:') read(5,*,err=5) iot end do if (iot.eq.0) then open(unit=9,file=f(1:lnblnk(f))//'fin_pa.t') else if (iot.eq.1) then open(unit=9,file=f(1:lnblnk(f))//'fin_pb.t') else if (iot.eq.2) then open(unit=9,file=f(1:lnblnk(f))//'fin.t') end if c open(unit=19,file=f1(1:lnblnk(f1))//'fin.t') c open(unit=29,file=f2(1:lnblnk(f2))//'fin.t') c open(unit=39,file=f3(1:lnblnk(f3))//'fin.t') write(6,*) 9 write(6,10) 10 format('$ anchura ventana sincronismo en T (muestras): ') read(5,*,err=9) ianchs_t 14 write(6,15) 15 format('$ anchura ventana promediado en T (muestras): ') read(5,*,err=14) ianchp_t return end c ------------------------------------------------------------- c Inizialixa ventanas c -------------------------------------------------------------- subroutine inizializa_ven(f,f1,f2,f3,ipqrs,ior,iop,iot, & npos_r,npos_p,npos_t,ianchs_r,ianchp_r,ianchs_p, & ianchp_p,ianchs_t,ianchp_t) c ipqrs: selecciona ventana entornoa P o a QRS c iop: si ipqrs es en P iop dice que seqal guardo; filtrada paso c alto o paso banda c npos: distancia del QRS al centro de la ventana de sincronismo c ianchs: anchura de la ventana de sincronismo c ianchp: anchura de la ventana de promediado character*12 f,f1,f2,f3 ipqrs=0 do while ((ipqrs.lt.1).or.(ipqrs.gt.7)) write(6,*) 5 write(6,*) ' ventana en: QRS [1] P [2] QRS-P [3]' write(6,*) ' QRS-P-T [4] T [5] P-T [6]' write(6,*) ' QRS-T [7] :' write(6,10) 10 format('$ OPCION:') read(5,*,err=5) ipqrs write(6,*) end do if (ipqrs.eq.1.or.ipqrs.eq.3 & .or.ipqrs.eq.4.or.ipqrs.eq.7) then call inicializa_ven_qrs(f,f1,f2,f3,npos_r,ior, & ianchs_r,ianchp_r) end if if (ipqrs.eq.2.or.ipqrs.eq.3 & .or.ipqrs.eq.4.or.ipqrs.eq.6) then call inicializa_ven_p(f,f1,f2,f3,npos_p,iop,ianchs_p,ianchp_p) end if if (ipqrs.eq.4.or.ipqrs.eq.5 & .or.ipqrs.eq.6.or.ipqrs.eq.7) then call inicializa_ven_t(f,f1,f2,f3,npos_t,iot,ianchs_t,ianchp_t) end if return end c --------------------------------------------------------------- c CREA VENTANAS PARA PROMEDIAR C --------------------------------------------------------------- c Crea ventanas segun especificaciones que pide subroutine crea_ventanas(ecg,ecgpa,ecgpb,ecgam1,ecgam2, & ecgam3,iqrs,nqrs,ifm, & is,ns,ipqrs,npos_r,npos_p,npos_t,ior,iop,iot, & ianchs_r,ianchp_r,ianchs_p,ianchp_p, & ianchs_t,ianchp_t,iret_pb,iret_pa) dimension ecg(100000),ecgpa(100000),ecgpb(100000) dimension ecgam1(100000), ecgam2(100000),ecgam3(100000) dimension iqrs(8000) if (ipqrs.eq.1.or.ipqrs.eq.3 & .or.ipqrs.eq.4.or.ipqrs.eq.7) then ianchi=ianchs_r/2 ianchd=ianchp_r - ianchi if (ior.eq.0) then call crefinqrs(7,1,ecgpa,iqrs,nqrs,ifm,is,ns,ior, & ianchi,ianchi,ianchp_r,npos_r,iret_pa,iret_pb) else if (ior.eq.1) then call crefinqrs(7,1,ecgpb,iqrs,nqrs,ifm,is,ns,ior, & ianchi,ianchi,ianchp_r,npos_r,iret_pa,iret_pb) else if (ior.eq.2) then call crefinqrs(7,1,ecg,iqrs,nqrs,ifm,is,ns,ior, & ianchi,ianchi,ianchp_r,npos_r,iret_pa,iret_pb) end if c call crefinqrs(17,2,ecgam1,iqrs,nqrs,ifm,is,ns,ior, c & ianchd,ianchi,ianchp_r,npos_r,iret_pa,iret_pb) c call crefinqrs(27,2,ecgam2,iqrs,nqrs,ifm,is,ns,ior, c & ianchd,ianchi,ianchp_r,npos_r,iret_pa,iret_pb) c call crefinqrs(37,2,ecgam3,iqrs,nqrs,ifm,is,ns,ior, c & ianchd,ianchi,ianchp_r,npos_r,iret_pa,iret_pb) end if if (ipqrs.eq.2.or.ipqrs.eq.3 & .or.ipqrs.eq.4.or.ipqrs.eq.6) then ianchi=ianchs_p/2 ianchd=ianchp_p - ianchi if (iop.eq.0) then call crefinp(8,1,ecgpa,iqrs,nqrs,ifm,is,ns,npos_p,iop, & ianchi,ianchi,ianchp_p,iret_pb,iret_pa) else if (iop.eq.1) then call crefinp(8,1,ecgpb,iqrs,nqrs,ifm,is,ns,npos_p,iop, & ianchi,ianchi,ianchp_p,iret_pb,iret_pa) else if (iop.eq.2) then call crefinp(8,1,ecg,iqrs,nqrs,ifm,is,ns,npos_p,iop, & ianchi,ianchi,ianchp_p,iret_pb,iret_pa) end if c call crefinp(18,2,ecgam1,iqrs,nqrs,ifm,is,ns,npos_p,iop, c & ianchd,ianchi,ianchp_p,iret_pb,iret_pa) C call crefinp(28,2,ecgam2,iqrs,nqrs,ifm,is,ns,npos_p,iop, C & ianchd,ianchi,ianchp_p,iret_pb,iret_pa) C call crefinp(38,2,ecgam3,iqrs,nqrs,ifm,is,ns,npos_p,iop, C & ianchd,ianchi,ianchp_p,iret_pb,iret_pa) end if if (ipqrs.eq.4.or.ipqrs.eq.5 & .or.ipqrs.eq.6.or.ipqrs.eq.7) then ianchi=ianchs_t/2 ianchd=ianchp_t - ianchi if (iot.eq.0) then call crefinp(9,1,ecgpa,iqrs,nqrs,ifm,is,ns,npos_t,iot, & ianchi,ianchi,ianchp_t,iret_pb,iret_pa) else if (iot.eq.1) then call crefinp(9,1,ecgpb,iqrs,nqrs,ifm,is,ns,npos_t,iot, & ianchi,ianchi,ianchp_t,iret_pb,iret_pa) else if (iot.eq.2) then call crefinp(9,1,ecg,iqrs,nqrs,ifm,is,ns,npos_t,iot, & ianchi,ianchi,ianchp_t,iret_pb,iret_pa) end if c call crefinp(19,2,ecgam1,iqrs,nqrs,ifm,is,ns,npos_t,iot, c & ianchd,ianchi,ianchp_t,iret_pb,iret_pa) c call crefinp(29,2,ecgam2,iqrs,nqrs,ifm,is,ns,npos_t,iot, c & ianchd,ianchi,ianchp_t,iret_pb,iret_pa) c call crefinp(39,2,ecgam3,iqrs,nqrs,ifm,is,ns,npos_t,iot, c & ianchd,ianchi,ianchp_t,iret_pb,iret_pa) end if return end C --------------------------------------------------------------- C CREACIO FITXER DE FINESTRES QRS (200 punts) C --------------------------------------------------------------- C Creacio d'una finestra de 200 punts [1-200], amb el valor C del QRS detectat posicionat a I=100. subroutine crefinqrs(iu,ifor,sen,iqrs,nqrs,ifm,is,ns,ior, & ianchd,ianchi,ianchp,npos,iret_pa,iret_pb) c iu: canal de escritura c ianchd: anchura de la ventana a la derecha de QRS c ianchi: anchura de de la ventana a la izquierda del QRS dimension sen(100000),iqrs(8000) l=1 if(iqrs(1)-npos.lt.ianchi) then l=2 end if do i=l,nqrs-1 inifin=iqrs(i)-npos-ianchi if (ifor.eq.1) then do j=inifin,inifin+ianchi+ianchd-1 write(iu,1) sen(j) end do else if (ifor.eq.2) then do j=inifin,inifin+ianchi+ianchd-1 write(iu,2) int(sen(j)) end do end if end do if (ior.eq.0) then iretard=iret_pa else if (ior.eq.1) then iretard=iret_pb + iret_pa else if (ior.eq.2) then iretard=0 end if if ((iqrs(nqrs)-npos+ianchp-ianchi+iretard).lt.((is+ns)*ifm) & .and.(nqrs.gt.0)) then inifin=iqrs(nqrs)-npos-ianchi if (ifor.eq.1) then do j=inifin,inifin+ianchi+ianchd-1 write(iu,1) sen(j) end do else if (ifor.eq.2) then do j=inifin,inifin+ianchi+ianchd-1 write(iu,2) int(sen(j)) end do end if end if 1 format(1x,f8.4) 2 format(1x,I6) return end C --------------------------------------------------------------- C ESCRIU FINESTRES P (200 punts) AMB EL FILTRAT SELECCIONAT C --------------------------------------------------------------- C Creacio d'una finestra de 200 punts [1-200], centrat a la C posicio del QRS menys NPOS (seleccionat en l'execucio). C Els valors recomenats soc: 120ms (PAC8) i 150ms (PAC1). C Considera el senyal filtrat passa alt o passa banda. subroutine crefinp(iu,ifor,sen,iqrs,nqrs,ifm,is,ns,npos,iop, & ianchd,ianchi,ianchp,iret_pb,iret_pa) dimension sen(100000),iqrs(8000) l=1 if(iqrs(1)-npos.lt.ianchi) then l=2 end if do i=l,nqrs-1 inifin=iqrs(i)-npos-ianchi if (ifor.eq.1) then do j=inifin,inifin+ianchd+ianchi-1 write(iu,1) sen(j) end do else if (ifor.eq.2) then do j=inifin,inifin+ianchd+ianchi-1 write(iu,2) int(sen(j)) end do end if end do if (iop.eq.0) then iretard=iret_pa else if (iop.eq.1) then iretard=iret_pb + iret_pa else if (iop.eq.2) then iretard=0 end if if ((iqrs(nqrs)-npos+ianchp-ianchi+iretard).lt.((is+ns)*ifm) & .and.(nqrs.gt.0)) then inifin=iqrs(nqrs)-npos-ianchi if (ifor.eq.1) then do j=inifin,inifin+ianchd+ianchi-1 write(iu,1) sen(j) end do else if (ifor.eq.2) then do j=inifin,inifin+ianchd+ianchi-1 write(iu,2) int(sen(j)) end do end if end if 1 format(1x,f8.4) 2 format(1x,I6) return end