**************************************************************
*     Programa guitar-0.11                                    *
*     Dibujo de perfiles longitudinales (guitarras)          *
*     Pere Hernández Casellas (24-10-2005)                   *
*     compila con g77 (GNU Fortran)                          *  
*     2023-11-08 Petites millores al codi                    *
**************************************************************

      program guitar

      character*80 nperfil
      character*30 nomp(10) ! número maximo de perfiles=10
      dimension npunt(100)  ! max 100 puntos por perfil
      dimension lcolor(10)
      dimension k(10,100)
      dimension x(10,100),y(10,100)

      nc1=12   !Definimos colores
      nc2=4
      nc3=5
      nc4=0
      
c     Lectura de fichero de datos

      open(20,file="guitar.dat")
      
      read(20,*) nperfil
      read(20,*) pkini
      read(20,*) pkfin
      read(20,*) stpk

      read(20,*) ctmin
      read(20,*) ctmax
      read(20,*) stct

      read(20,*) svh

      read(20,*) nperf

      write(*,*) nperfil

      do i=1,nperf

      read(20,*) nomp(i)
      read(20,*) npunt(i)
      read(20,*) lcolor(i)

      write(*,*) nomp(i), " Npunt=", npunt(i)," Color=",lcolor(i)

c     Lee y escribe los puntos de cada perfil

      do j=1,npunt(i)

      read(20,*) k(i,j),x(i,j),y(i,j)

      write(*,*) k(i,j),x(i,j),y(i,j)
      end do
      end do

      read(20,*) scll
      read(20,*) svli     


c     Abrimos archivo de dibujo guitar.dxf      
     
      open(22,file='guitar.dxf')

      write(22,'(I1,/,A,/,I1,/,A)') 0,"SECTION",2,"ENTITIES"

c     Título del gráfico

      call text(pkini,-(ctmax*svh+svli*1.5),scll*3.,0.,nc4,nperfil)

c     Dibujamos la caja de perfiles
 
      do xpk=pkini,pkfin,stpk
      call line(xpk,-ctmin*svh,xpk,-ctmax*svh,nc1)
      end do
      
      do ypk=ctmin,ctmax,stct
      ypkk=ypk*svh
      call line(pkini,-ypkk,pkfin,-ypkk,nc1)
      end do

c     Dibujamos rótulos en el eje de PKs

      do xpk=pkini,pkfin,stpk     
      call textn(xpk,-(ctmin*svh-svli*1.2),scll,90.,nc5,xpk)
      end do

c     Dibujamos rótulos en el eje de cotas

      do yct=ctmin,ctmax,stct     
      call textn(pkini-svli,-yct*svh,scll,0.,nc5,yct)
      end do


c     Dibujamos las cuerdas de la guitarra con sus valores
      
      do i=1,nperf
      
      yct=ctmin*svh-(i+1)*svli*1.2
      call line(pkini,-yct,pkfin,-yct,lcolor(i))

      call text(pkini-3*svli,-yct,scll*1.2,0.,lcolor(i),nomp(i))

      do j=1,npunt(i)
      call textn(x(i,j),-(yct-svli),scll,90.,lcolor(i),y(i,j))
      call line(x(i,j),-(yct-0.05*svli),x(i,j),-(yct+0.05*svli),
     &lcolor(i))
      end do

      do xpk=pkini,pkfin,stpk     
      call line(xpk,-(yct-0.05*svli),xpk,-(yct+0.05*svli),nc5)
      end do

      end do


c     Dibujamos los perfiles:

      do i=1,nperf
      do j=1,npunt(i)

      if(j.lt.npunt(i)) then
      
      x1=x(i,j)
      y1=y(i,j)*svh
      x2=x(i,j+1)
      y2=y(i,j+1)*svh

      call line(x1,-y1,x2,-y2,lcolor(i))

      endif

      end do
      end do


c     Cierre del archivo .dxf
      write(22,'(I1,/,A,/,I1,/,A)') 0,"ENDSEC",0,"EOF"

      close(20)
      close(22)
      
      end

c     Subrutina para dibujar lineas

      subroutine line(p1x,p1y,p2x,p2y,linecolor)
c     line P1-P2
c      write(22,*)
      write(22,'(I1,/,A,/,I1,/,A)') 0,"LINE",8,"default"
      write(22,'(I1,/,A)') 6,"CONTINUOUS"
      write(22,'(I2,/,F6.1,/,I2,/,F6.1)') 10,p1x,20,-p1y
      write(22,'(I2,/,F6.1,/,I2,/,F6.1)') 11,p2x,21,-p2y
      write(22,'(I2,/,I2,/,I2,/,I2)') 39,0,62,linecolor
      return
      end

c     Subrutina para dibujar texto

      subroutine text(px,py,esct,orid,ltcolor,texto)
      real px,py,esct,orid
      character(*) texto
c      write(22,*)
      write(22,'(I1,/,A,/,I1,/,A)') 0,"TEXT",8,"default"
      write(22,'(I1,/,A)') 6,"CONTINUOUS"
      write(22,'(I2,/,F6.1,/,I2,/,F6.1)') 10,px,20,-py
      write(22,'(I2,/,F6.1,/,I2,/,F6.1)') 40,esct,50,orid
      write(22,'(I2,/,I2)') 72,0
      write(22,'(I2,/,A)') 7,"Normal#2.000000#6.000000"
      write(22,'(I2,/,A)') 1,texto
      write(22,'(I2,/,I2,/,I2,/,I2)') 39,0,62,ltcolor
      return
      end

c     Subrutina para dibujar numeros

      subroutine textn(px,py,esct,orid,ltcolor,texton)
      real px,py,esct,orid,texton
c      write(22,*)
      write(22,'(I1,/,A,/,I1,/,A)') 0,"TEXT",8,"default"
      write(22,'(I1,/,A)') 6,"CONTINUOUS"
      write(22,'(I2,/,F6.1,/,I2,/,F6.1)') 10,px,20,-py
      write(22,'(I2,/,F6.1,/,I2,/,F6.1)') 40,esct,50,orid
      write(22,'(I2,/,I2)') 72,0
      write(22,'(I2,/,A)') 7,"Normal#2.000000#6.000000"
      write(22,'(I2,/,F7.3)') 1,texton
      write(22,'(I2,/,I2,/,I2,/,I2)') 39,0,62,ltcolor
      return
      end