Added parsing section for additional settings in collimator DB

SixTrack · vkbo · Sep 9, 2019 · Aug 30, 2019 · Aug 30, 2019 · Sep 2, 2019
commit a8db811f220e5a94a6cd6ed1fd1bdd1570fb9835
diff --git a/source/coll_db.f90 b/source/coll_db.f90
@@ -23,8 +23,9 @@ module coll_db
   logical,                  public,  save :: cdb_doNSig   = .false. ! Use the sigmas from fort.3 instead of DB
   integer,                  public,  save :: cdb_nColl    = 0       ! Number of collimators
   integer,                  public,  save :: cdb_nFam     = 0       ! Number of collimator families
+  integer,                  public,  save :: cdb_setPos   = 0       ! The position in the DB file where the settings start
 
-  ! Database arrays
+  ! Main Database Arrays
   character(len=:), allocatable, public, save :: cdb_cName(:)       ! Collimator name
   character(len=:), allocatable, public, save :: cdb_cNameUC(:)     ! Collimator name upper case
   character(len=:), allocatable, public, save :: cdb_cMaterial(:)   ! Collimator material
@@ -38,6 +39,9 @@ module coll_db
   real(kind=fPrec), allocatable, public, save :: cdb_cBy(:)         ! Collimator beta y
   logical,          allocatable, public, save :: cdb_cFound(:)      ! Found in lattice
 
+  ! Additional Settings Arrays
+  integer,          allocatable, public, save :: cdb_cSides(:)      ! 0 = two-sided, or 1,2 for single side 1 or 2
+
   ! Family Arrays
   character(len=:), allocatable, public, save :: cdb_famName(:)     ! Family name
   real(kind=fPrec), allocatable, public, save :: cdb_famNSig(:)     ! Family sigma
@@ -48,12 +52,19 @@ module coll_db
 
 contains
 
+! ================================================================================================ !
+!  V.K. Berglyd Olsen, BE-ABP-HSS
+!  Created: 2019-03-19
+!  Updated: 2019-08-30
+!  Change the size of the collimator database arrays
+! ================================================================================================ !
 subroutine cdb_allocDB
 
   use parpro
   use mod_alloc
   use numerical_constants
 
+  ! Main Database Arrays
   call alloc(cdb_cName,     mNameLen, cdb_nColl, " ",           "cdb_cName")
   call alloc(cdb_cNameUC,   mNameLen, cdb_nColl, " ",           "cdb_cNameUC")
   call alloc(cdb_cMaterial, 4,        cdb_nColl, " ",           "cdb_cMaterial")
@@ -67,8 +78,17 @@ subroutine cdb_allocDB
   call alloc(cdb_cBy,                 cdb_nColl, zero,          "cdb_cBy")
   call alloc(cdb_cFound,              cdb_nColl, .false.,       "cdb_cFound")
 
+  ! Additional Settings Arrays
+  call alloc(cdb_cSides,              cdb_nColl, 0,             "cdb_cSides")
+
 end subroutine cdb_allocDB
 
+! ================================================================================================ !
+!  V.K. Berglyd Olsen, BE-ABP-HSS
+!  Created: 2019-03-19
+!  Updated: 2019-08-30
+!  Change the size of the collimator family arrays
+! ================================================================================================ !
 subroutine cdb_allocFam
 
   use parpro
@@ -80,14 +100,16 @@ subroutine cdb_allocFam
 
 end subroutine cdb_allocFam
 
+! ================================================================================================ !
+!  V.K. Berglyd Olsen, BE-ABP-HSS
+!  Created: 2019-03-19
+!  Updated: 2019-08-30
+!  Change the size of other arrays depending on external size parameters
+! ================================================================================================ !
 subroutine cdb_expand_arrays(nele_new)
-
   use mod_alloc
-
   integer, intent(in) :: nele_new
-
   call alloc(cdb_elemMap,nele_new,0,"cdb_elemMap")
-
 end subroutine cdb_expand_arrays
 
 ! ================================================================================================ !
@@ -142,6 +164,11 @@ subroutine cdb_readCollDB
     call cdb_readDB_newFormat
   end if
 
+  if(cdb_setPos > 0) then
+    ! The DB has additional SETTINGS, parse them
+    call cdb_readDBSettings
+  end if
+
 #ifdef ROOT
   call cdb_writeDB_ROOT
 #endif
@@ -185,6 +212,13 @@ subroutine cdb_readCollDB
 
 end subroutine cdb_readCollDB
 
+! ================================================================================================ !
+!  V.K. Berglyd Olsen, BE-ABP-HSS
+!  Created: 2019-03-19
+!  Updated: 2019-08-30
+!  Parsing the collimator section of the new database format. That is, the sigma settings and the
+!  collimator descriptions. The parsing ends when it reaches the SETTINGS keyword.
+! ================================================================================================ !
 subroutine cdb_readDB_newFormat
 
   use parpro
@@ -205,6 +239,8 @@ subroutine cdb_readDB_newFormat
   iLine = 0
   iColl = 0
 
+  write(lout,"(a)") "COLLDB> Reading collimator database, new format"
+
   call f_requestUnit(cdb_fileName, dbUnit)
   call f_open(unit=dbUnit,file=cdb_fileName,formatted=.true.,mode="r",status="old",err=fErr)
   if(fErr) then
@@ -227,6 +263,13 @@ subroutine cdb_readDB_newFormat
     write(lerr,"(a,i0)") "COLLDB> ERROR Failed to parse database line ",iLine
     call prror
   end if
+  if(nSplit == 0) goto 10 ! Skip empty lines
+
+  if(lnSplit(1) == "SETTINGS") then
+    write(lout,"(a,i0)") "COLLDB> SETTINGS flag encountered in collimator database on line ",iLine
+    cdb_setPos = iLine
+    goto 20
+  end if
 
   if(lnSplit(1) == "NSIG_FAM") then
     ! Collimator Family
@@ -294,6 +337,13 @@ subroutine cdb_readDB_newFormat
 
 end subroutine cdb_readDB_newFormat
 
+! ================================================================================================ !
+!  V.K. Berglyd Olsen, BE-ABP-HSS
+!  Created: 2019-03-19
+!  Updated: 2019-03-20
+!  Parses the old style database format with one calue per line. The routine also writes back out
+!  the same database with the new file format.
+! ================================================================================================ !
 subroutine cdb_readDB_oldFormat
 
   use crcoall
@@ -309,6 +359,8 @@ subroutine cdb_readDB_oldFormat
 
   cErr = .false.
 
+  write(lout,"(a)") "COLLDB> Reading collimator database, old format"
+
   call f_requestUnit(cdb_fileName, dbUnit)
   call f_open(unit=dbUnit,file=cdb_fileName,formatted=.true.,mode="r",status="old")
 
@@ -431,6 +483,124 @@ subroutine cdb_readDB_oldFormat
 
 end subroutine cdb_readDB_oldFormat
 
+! ================================================================================================ !
+!  V.K. Berglyd Olsen, BE-ABP-HSS
+!  Created: 2019-08-30
+!  Updated: 2019-08-30
+!  Parse additional settings from the collimator database. This is treated separately since this
+!  section is parsed in a standard name/value format like an input block in fort.3
+! ================================================================================================ !
+subroutine cdb_readDBSettings
+
+  use parpro
+  use crcoall
+  use string_tools
+  use mod_units
+  use mod_alloc
+  use numerical_constants
+
+  character(len=:), allocatable :: lnSplit(:)
+  character(len=mInputLn) inLine
+  integer i, dbUnit, ioStat, nSplit, iLine, iColl, iFam, iTemp
+  logical cErr, fErr, isFam
+
+  fErr  = .false.
+  cErr  = .false.
+  iLine = 0
+
+  write(lout,"(a)") "COLLDB> Reading additional settings from collimator database"
+
+  call f_requestUnit(cdb_fileName, dbUnit)
+  call f_open(unit=dbUnit,file=cdb_fileName,formatted=.true.,mode="r",status="old",err=fErr)
+  if(fErr) then
+    write(lerr,"(a)") "COLLDB> ERROR Cannot read from '"//trim(cdb_fileName)//"'"
+    call prror
+  end if
+
+10 continue
+  iLine = iLine + 1
+
+  read(dbUnit,"(a)",end=20,iostat=ioStat) inLine
+  if(iLine <= cdb_setPos) goto 10 ! Skip already parsed lines
+
+  if(ioStat /= 0) then
+    write(lerr,"(a)") "COLLDB> ERROR Cannot read from '"//trim(cdb_fileName)//"'"
+    call prror
+  end if
+  if(inLine(1:1) == "#") goto 10
+
+  call chr_split(inLine, lnSplit, nSplit, cErr)
+  if(cErr) then
+    write(lerr,"(a)") "COLLDB> ERROR Failed to parse database line"
+    goto 30
+  end if
+  if(nSplit == 0) goto 10 ! Skip empty lines
+
+  ! Look up the target collimator or family
+  iFam  = -1
+  iColl = -1
+  isFam = .false.
+  if(nSplit >= 2) then
+    iFam  = cdb_getFamilyID(lnSplit(2))
+    iColl = cdb_getCollimatorID(lnSplit(2))
+    if(iFam == -1 .and. iColl == -1) then
+      write(lerr,"(a)") "COLLDB> ERROR Could not find '"//trim(lnSplit(2))//"' in neither collimator nor family database"
+      goto 30
+    end if
+    if(iFam > 0 .and. iColl > 0) then
+      write(lerr,"(a)") "COLLDB> ERROR Found '"//trim(lnSplit(2))//"' in both collimator and family database"
+      goto 30
+    end if
+    isFam = iFam > 0
+  else
+    write(lerr,"(a)") "COLLDB> ERROR Each keyword in the SETTINGS section of the collimator database requires "//&
+      "a target collimator or family name"
+    goto 30
+  end if
+
+  ! Parse the keywords
+  select case(lnSplit(1))
+
+  case("ONESIDED")
+    if(nSplit /= 3) then
+      write(lerr,"(a,i0)") "COLLDB> ERROR ONESIDED expects 2 values, got ",nSplit-1
+      write(lerr,"(a)")    "COLLDB>       ONESIDED collname|famname 1|2"
+      goto 30
+    end if
+    call chr_cast(lnSplit(3), iTemp, cErr)
+    if(iTemp /= 1 .and. iTemp /= 2) then
+      write(lerr,"(a,i0)") "COLLDB> ERROR ONESIDED collimator value must be 1 or 2, got ",iTemp
+      goto 30
+    end if
+    if(isFam) then
+      do i=1,cdb_nColl
+        if(cdb_cFamily(iFam) == iFam) then
+          cdb_cSides(i) = iTemp
+        end if
+      end do
+    else
+      cdb_cSides(iColl) = iTemp
+    end if
+
+  case default
+    write(lerr,"(a)") "COLLDB> ERROR Unknown keyword '"//trim(lnSplit(1))//"' in SETTINGS section"
+    goto 30
+
+  end select
+
+  goto 10
+
+20 continue
+
+  call f_close(dbUnit)
+  return
+
+30 continue
+  write(lerr,"(a,i0)") "COLLDB> ERROR Collimator DB '"//trim(cdb_fileName)//"' on line ",iLine
+  call prror
+
+end subroutine cdb_readDBSettings
+
 #ifdef ROOT
 subroutine cdb_writeDB_ROOT
 
@@ -559,6 +729,29 @@ integer function cdb_getFamilyID(famName) result(famID)
 
 end function cdb_getFamilyID
 
+! ================================================================================================ !
+!  V.K. Berglyd Olsen, BE-ABP-HSS
+!  Created: 2019-08-30
+!  Updated: 2019-08-30
+!  Find a collimator in the database and returns its ID
+! ================================================================================================ !
+integer function cdb_getCollimatorID(collName) result(collID)
+
+  character(len=*), intent(in) :: collName
+  integer i
+
+  collID = -1
+  if(cdb_nColl > 0) then
+    do i=1,cdb_nColl
+      if(cdb_cName(i) == collName) then
+        collID = i
+        exit
+      end if
+    end do
+  end if
+
+end function cdb_getCollimatorID
+
 ! ================================================================================================ !
 !  V.K. Berglyd Olsen, BE-ABP-HSS
 !  Created: 2019-03-21