c PROGRAMMA PER L'ANALISI DI IMMAGINI TERMOGRAFICHE
c
c      Questo programma permette l'analisi
c     di linee o colonne di una termografia infrarosso
c
      INCLUDE 'FGRAPH.FI'
      INCLUDE 'FGRAPH.FD'
      RECORD/RCCOORD/CURPOS
      parameter (noimm=50)
      integer datiim(256,200),c0,c1,c2,contrasto,lmax,lmin
      INTEGER ASCISI,px,py,pxx,pyy
      integer*2 STATUS
      integer ORDINI,I
      integer imm
      real tbianc,tnero,tempim(256,50)
      character label*2,nomesequenza*26,ctempim(256,50)*7
      character*1 rispos,rico
      character*5 fole
      character*7 passaggio
      INTEGER*4 RGB
c scelta del file da analizzare
1     lmax=0
      lmin=257
      call clearscreen ($gclearscreen)
      write(*,*)'                                      RICO'
      write(*,*)
      write(*,*)'Questo programma permette di selezionare ed analizzare
     *una riga o una colonna  '
      write(*,*)'di una sequenza di termografie (max 50) infrarosso.'
      read(*,*)
      call sequenza(fole,datiim,lmax,lmin,px,py,*70)
c selezione modalit… grafica a 16 colori, 640 x 480 pixel
3     call clearscreen ($gclearscreen)
      STATUS=SETVIDEOMODE($VRES16COLOR)
C Selezione paletta a 16 tonalit… di grigio
      DO I=2,62,4
	RGB=ISHL(ISHL(I,8).OR.I,8).OR.I
	STATUS=REMAPPALETTE(I/4,RGB)
      ENDDO
c Inserimento del contrasto
45    call puliscischermo
      lmin=257
      lmax=0
      c0=0
      c1=0
      c2=0
      call settextposition(3,1,curpos)
      call outtext('Inserisci il contrasto con cui visualizzare l''immag
     *ine (1-16) ')
      read(*,*)contrasto
      if ((contrasto.lt.1).or.(contrasto.gt.16)) goto 45
	c2=14*(17-contrasto)
	c1=28*(contrasto-1)
	c0=15+contrasto
c visualizzazione dell'immagine
450   call visual (datiim,c0,c1,c2,lmax,lmin,1,px,1,py,px,py)
c richiesta di modifica del contrasto
46    call puliscischermo
      call settextposition(3,1,curpos)
      call outtext('Vuoi cambiare il contrasto (s/n) ? ')
      read (*,'(a1)') rispos
      if ((rispos.eq.'s').or.(rispos.eq.'S')) goto 45
      if ((rispos.ne.'n').and.(rispos.ne.'N')) goto 46
c inserimento del range di temperature
      call puliscischermo
10    CALL SETTEXTPOSITION(3,1,CURPOS)
      STATUS= SETTEXTCOLOR(14)
      CALL OUTTEXT('Immettere la temperatura corrispondente al nero ')
      read(*,*)tnero
      if ((tnero.lt.-999.99).or.(tnero.gt.999.98)) goto 10
2020  CALL PULISCISCHERMO
      call settextposition(3,1,curpos)
      call outtext('Immettere la temperatura corrispondente al bianco ')
      read(*,*)tbianc
      if ((tbianc.lt.-999.98).or.(tbianc.gt.999.99)) goto 2020
      if (tbianc.le.tnero) then
	CALL PULISCISCHERMO
	call settextposition(1,1,curpos)
	call outtext('La temperatura del nero deve essere minore di quella
     * del bianco.')
	goto 10
      endif
c visualizzazione griglia
8     call PULISCISCHERMO
      call grigli(1,px,1,py,px,py)
c selezione righe o colonne da analizzare
4     call puliscischermo
      CALL SETTEXTPOSITION(2,1,CURPOS)
      write(*,*)'Vuoi analizzare una riga o una colonna (R/C) ? '
      read(*,'(a1)')rico
5     if ((rico.eq.'r').or.(rico.eq.'R')) then
        call puliscischermo
57      call SETTEXTPOSITION(3,1,CURPOS)
	write(*,*)' Inserire l''ordinata della riga '
	read(*,*) ordini
1115     if ((ordini.gt.py).or.(ordini.lt.1)) then
	   call puliscischermo
	   call settextposition(1,1,curpos)
	   call outtext('ORDINATA FUORI RANGE, reinserirla ')
	   read(*,*) ordini
	   goto 1115
	 endif
	 goto 2222
	endif
	if ((rico.eq.'c').or.(rico.eq.'C')) then
	  call puliscischermo
	  call settextposition (3,1,curpos)
	  write(*,*)' Inserire l''ascissa della colonna '
	  read(*,*) ascisi
1112      if ((ascisi.gt.px).or.(ascisi.lt.1)) then
	    call puliscischermo
	    call settextposition(1,1,curpos)
	    call outtext('ASCISSA INIZIALE FUORI RANGE, reinserirla ')
	    read(*,*) ascisi
	    GOTO 1112 
	    endif  
	else
	  goto 4  
	ENDIF
c Evidenziazione della zona
2222    call puliscischermo
	status=setcolor(15)
	if ((rico.eq.'c').or.(rico.eq.'C')) then
	  do i=1,py
	    status=setpixel(2*ascisi+int((640-px*2)/2+.5)-1,2*i+(480-py*2)
     *)
	  enddo
	  goto 789
	endif
	do i=1,px
	    status=setpixel(2*i+int((640-px*2)/2+.5),2*ordini+(480-py*2-1)
     *)
	enddo
789     call settextposition(2,1,curpos)
	status=setcolor(14)
	call outtext('E'' giusta (s/n) ? ')
	read(*,'(a1)')rispos
	if ((rispos.eq.'n').or.(rispos.eq.'N')) then   
	  call visual(datiim,c0,c1,c2,lmax,lmin,ascisi,ordini,px,pxx,py,py
     *y)  
	  call grigli(ascisi,ordini,px,pxx,py,pyy)
	  goto 5  
	endif  
	if ((rispos.ne.'s').and.(rispos.ne.'S')) goto 2222
c Numero dei punti
	if ((rico.eq.'c').or.(rico.eq.'C')) n=200
	if ((rico.eq.'r').or.(rico.eq.'R')) n=256
c elaborazioni sequenze
128   status=setvideomode($defaultmode)
      call clearscreen($gclearscreen)
      write(*,*)
      write(*,*)'Elaborando i dati...'
      write(*,*)'mumble mumble...'
      do imm=1,51
c etichette trattate con il codice ASCII
	if (imm.le.9) then
	  label='0'//char(imm+48)
	else if (imm.le.19) then
	  label='1'//char(imm+38)
	else if (imm.le.29) then
	  label='2'//char(imm+28)
	else if (imm.le.39) then
	  label='3'//char(imm+18)
	else if (imm.le.49) then
	  label='4'//char(imm+8)
	else if (imm.le.59) then
	  label='5'//char(imm-2)
	else if (imm.le.69) then
	  label='6'//char(imm-12)
	else if (imm.le.79) then
	  label='7'//char(imm-22)
	else if (imm.le.89) then
	  label='8'//char(imm-32)
	else
	  label='9'//char(imm-42)
	endif
c Lettura delle immagini
	nomesequenza='c:\lab98\termo\'//fole//label//'.raw'
	call prelev(nomesequenza,datiim,lmax,lmin,px,py,*129)
c Elaborazione delle sequenze
	call elabor(tempim,ordini,ascisi,tbianc,tnero,datiim,rico,imm)
c conversione cifre-caratteri
      if ((rico.eq.'r').or.(rico.eq.'R')) then      
	do j=1,256
	  write(passaggio,'(f7.2)')tempim(j,imm)+0.005
	    ctempim(j,imm)=passaggio(1:4)//','//passaggio(6:7)
	enddo
      endif
      if ((rico.eq.'c').or.(rico.eq.'C')) then
	do j=1,200
	  write(passaggio,'(f7.2)')tempim(j,imm)+0.005
	    ctempim(j,imm)=passaggio(1:4)//','//passaggio(6:7)
	enddo
      endif

      enddo
c Scrittura del file con i dati
129   if ((rico.eq.'r').or.(rico.eq.'R')) then
	  open(1,file='c:\lab98\termo\riga.dat',status='new',err=130)
      endif
      if ((rico.eq.'c').or.(rico.eq.'C')) then
	  open(1,file='c:\lab98\termo\colonna.dat',status='new',err=130)
      endif
150      write(1,202)
      
	if ((rico.eq.'c').or.(rico.eq.'C')) s=200
	if ((rico.eq.'r').or.(rico.eq.'R')) s=256
	   
c scrittura sul file .DAT           
      do j=1,s
	  write(1,201)j,(ctempim(j,imm),imm=1,50)
      enddo 
      close (1)
202   format (2x,'NøDATO',50(2x,'\\\\\\\\\\\\\\\',2x,'IMMAG. '))
201   format (2x,i6,50(2x,'\\\\\\\\\\\\\\\',2x,a7))
c chiede se rieseguire il programma
9     CALL CLEARSCREEN($GCLEARSCREEN)
70    write(*,*)'Altra analisi (s/n) ? '
      rispos=' '
      read(*,'(A1)')rispos
      if ((rispos.eq.'s').or.(rispos.eq.'S')) goto 1
      if ((rispos.ne.'n').and.(rispos.ne.'N')) goto 9
      stop
c Nuovo file
130   close (1)
      print *,' '
      if ((rico.eq.'r').or.(rico.eq.'R')) print *,'riga.dat Š gi… esiste
     *nte.'
      if ((rico.eq.'c').or.(rico.eq.'C')) print *,'colonna.dat Š gi… esi
     *stente.'
      print *,'Lo sovrascrivo (s/n) ? '
      read(*,'(a1)')rispos
      if ((rispos.eq.'s').or.(rispos.eq.'S')) then
	if ((rico.eq.'r').or.(rico.eq.'R')) open(1,file='c:\lab98\termo\ri
     *ga.dat',status='old')
	if ((rico.eq.'c').or.(rico.eq.'C')) open(1,file='c:\lab98\termo\co
     *lonna.dat',status='old')
	goto 150
      endif
      if ((rispos.ne.'n').and.(rispos.ne.'N').and.(rispos.ne.'s.').and.(
     *rispos.ne.'S')) goto 130
	if ((rico.eq.'r').or.(rico.eq.'R')) open(1,file='c:\lab98\temp\rig
     *a.dat',status='new',err=501)
	if ((rico.eq.'c').or.(rico.eq.'C')) open(1,file='c:\lab98\temp\col
     *onna.dat',status='new',err=501)
505     write(*,*)
	write(*,*)
	write(*,*)'ATTENZIONE'
	write(*,*)'Il file si trova nel percorso c:\lab98\temp\.'
	write(*,*)'E'' consigliato trasferirlo in un''altra directory'
	write(*,*)'perchŠ qui sar… sovrascritto senza richiesta di'
	write(*,*)'conferma.'
	write(*,*)
	write(*,*)'Premi INVIO per continuare'
	read (*,*)
      goto 150
501   if ((rico.eq.'r').or.(rico.eq.'R')) open(1,file='c:\lab98\temp\rig
     *a.dat',status='old')
      if ((rico.eq.'c').or.(rico.eq.'C')) then
	open(1,file='c:\lab98\temp\colonna.dat',status='old')  
      endif
	     goto505
      end
c-----------------------------------------------------------------------
c carica l'immagine
      subroutine prelev (nomefile,datiim,lmax,lmin,px,py,*)
      character riga*256,nomefile*26
      integer px,py,i,j,datiim(256,200),lmax,lmin
c apertura del file
      open (unit=1,file=nomefile,STATUS='OLD',err=100,access='direct',re
     *cl=px)
c prelevamento della matrice dati
      do i=1,py
	read (1,rec=i) riga(1:px)
	do j=1,px
c conversione da carattere ad ascii corrispondente
	  datiim(j,i)=ichar(riga(j:j))
	  lmax=max(lmax,datiim(j,i))
	  lmin=min(lmin,datiim(j,i))
	enddo
      enddo
      close (1)
      return
c in caso di errore
100   call clearscreen ($gclearscreen)
      close (1)
	return 1
      end
c-----------------------------------------------------------------------
c subroutine elaborazione output
      subroutine elabor (tempim,ordini,ascisi,tbianc,tnero,datiim,rico,i
     *mm)
      parameter (noimm=50)
      integer i
      integer ordini,ascisi
      integer datiim(256,200)
      real tempim(256,50),tbianc,tnero
      character rico*1
c Ciclo su tutta la riga o la colonna
      if ((rico.eq.'r').or.(rico.eq.'R')) then
	  do i=1,256
	    tempim(i,imm)=(tbianc-tnero)/256*datiim(i,ordini)+tnero
	  enddo
	  return
      endif
      do i=1,200
	  tempim(i,imm)=(tbianc-tnero)/256*datiim(ascisi,i)+tnero
      enddo
      end
c-----------------------------------------------------------------------
c visualizza l'immagine
      subroutine visual (datiim,c0,c1,c2,lmax,lmin,px,pxx,py,pyy,x,y)
      INCLUDE 'FGRAPH.FD'
      real k
      integer*2 status
      integer i,j,c0,c1,c2,lmax,lmin,l,px,py,pxx,pyy,x,y
      integer datiim(256,200)
      integer*4 ncolor
      lmax=0
      lmin=257
      l=0
      do i=py,pyy
	do j=px,pxx
	    k=(datiim(j,i)-lmin)/float(lmax-lmin)
	    l=(c2*k*k+c1*k+c0)/c0
	  ncolor=17-l
	  status=setcolor(ncolor)
      status=setpixel(2*j+(int((640-x*2)/2+0.5)-1),2*i+(480-y*2-1))
      status=setpixel(2*j+(int((640-x*2)/2+0.5)),2*i+(480-y*2))
      status=setpixel(2*j+(int((640-x*2)/2+0.5)),2*i+(480-y*2-1))
      status=setpixel(2*j+(int((640-x*2)/2+0.5)-1),2*i+(480-y*2))
	enddo
      enddo
      return
      END
c-----------------------------------------------------------------------
c visualizza la griglia
      subroutine grigli(px,pxx,py,pyy,x,y)
      INCLUDE 'FGRAPH.FD'
      integer*2 status
      INTEGER I,J,pxx,pyy,px,py,x,y
      DO I=py,pyy
	DO J=px,pxx
	  IF ((I/50.EQ.I/50.).OR.(J/50.EQ.J/50.)) THEN
	    STATUS=SETCOLOR(0)
	    STATUS=SETPIXEL(2*J+int((640-x*2)/2+0.5)-1,2*I+(480-y*2-1))
	  ELSE IF ((I/10.EQ.I/10.).OR.(J/10.EQ.J/10.)) THEN
	    STATUS=SETCOLOR(15)
	    STATUS=SETPIXEL(2*J+int((640-x*2)/2+0.5)-1,2*I+(480-y*2-
     *1))
	  ENDIF
	ENDDO
      ENDDO
      return
      END
c-----------------------------------------------------------------------
C PULITURA DELLO SCHERMO
      SUBROUTINE PULISCISCHERMO
      INCLUDE 'FGRAPH.FD'
      RECORD/RCCOORD/CURPOS
      INTEGER i
      DO i=1,4
	CALL settextposition(i,1,curpos)
	CALL OUTTEXT('
     *
     *')
      ENDDO
      do i=5,20
	call settextposition(i,1,curpos)
	call outtext('    ')
      enddo
      END
c-----------------------------------------------------------------------
c input sequenza
      subroutine sequenza(fole,datiim,lmax,lmin,px,py,*)
      include 'fgraph.fd'
      character fole*5,nomesequenza*26
      integer lmax,lmin,px,py,datiim(256,200)
1     call clearscreen($gclearscreen)
      write(*,*)
      write(*,*)
      write(*,*)'La sequenza deve essere composta da file in formato .RA
     *W, con nome'
      write(*,*)'composto da 5 lettere pi— due cifre che ne danno l''ord
     *ine. Deve'
      write(*,*)'essere, inoltre, nel percorso c:\lab98\termo\.'
      write(*,*)
      write(*,*)'Introdurre il nome dei file (5 lettere)'
      read(*,'(a5)')fole
      if (fole.eq.'muoni') then
	call clearscreen ($gclearscreen)
	write(*,*)
	write(*,*)
	write(*,*)'Questo programma Š stato scritto da'
	write(*,*)'Maurizio Antonelli'
	write(*,*)'Nø di matricola 537810'
	write(*,*)'
     *                 1999'
	write(*,*)
	write(*,*)
	return 1
      endif
      nomesequenza='c:\lab98\termo\'//fole//'01.raw'
c dimensionamento immagini della sequenza
      call dimensionamento(px,py)
      call prelev(nomesequenza,datiim,lmax,lmin,px,py,*1)
      return
      end
c-----------------------------------------------------------------------
c subroutine dimensioni delle immagini
      subroutine dimensionamento(px,py)
      integer px,py,a,b,c,d,e,f
      character formato*7
1000  call clearscreen($gclearscreen)
      write(*,*)
      write(*,*)'Inserisci il formato dell''immagine (max = 256x200 , mi
     *n = 100x100) '
      write(*,*)'Premi solo INVIO per scegliere il formato massimo. '
      write(*,*)
      read(*,'(a7)')formato
      if (formato.eq.'       ') then
	px=256
	py=200
	goto 1001
      endif
      a=ichar(formato(1:1))-48
      b=ichar(formato(2:2))-48
      c=ichar(formato(3:3))-48
      d=ichar(formato(5:5))-48
      e=ichar(formato(6:6))-48
      f=ichar(formato(7:7))-48
      if (a.lt.0) goto 1000
      if (a.gt.9) goto 1000
      if (b.lt.0) goto 1000
      if (b.gt.9) goto 1000
      if (c.lt.0) goto 1000
      if (c.gt.9) goto 1000
      if ((formato(4:4).ne.'x').and.(formato(4:4).ne.'X')) goto 1000
      if (d.lt.0) goto 1000
      if (d.gt.9) goto 1000
      if (e.lt.0) goto 1000
      if (e.gt.9) goto 1000
      if (f.lt.0) goto 1000
      if (f.gt.9) goto 1000
      px=a*100+b*10+c
      py=d*100+e*10+f
      if((px.lt.100).or.(px.gt.256).or.(py.lt.100).or.(py.gt.200)) goto
     *1000
1001  return
      end