diff --git a/resources/CoVeGa_v63_voorRapport_Inhalation.prn b/resources/CoVeGa_v63_voorRapport_Inhalation.prn index d47cef4..0497c76 100644 --- a/resources/CoVeGa_v63_voorRapport_Inhalation.prn +++ b/resources/CoVeGa_v63_voorRapport_Inhalation.prn @@ -2,9 +2,9 @@ Nuclides ICRP-107 Used dataset: Worker, 5 EXT NUCL Worker, 1 ?m Worker, 5 ? H-3 4.10E-11 4.10E-11 4.10E-11 1.20E-09 1.00E-09 6.30E-10 3.80E-10 2.80E-10 2.60E-10 Al DCs in units of Sv/Bq Be-7 4.60E-11 5.20E-11 4.60E-11 2.80E-10 2.40E-10 1.40E-10 9.60E-11 6.80E-11 5.50E-11 Be-10 1.90E-08 3.20E-08 1.90E-08 9.90E-08 9.10E-08 6.10E-08 4.20E-08 3.70E-08 3.50E-08 Values taken from file (pasted as values): - C-10 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 N:\Projecten\SamenwerkingBelV\Werksessie_nov2020\DCCs\Inh_ + C-10 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 C-11 3.20E-12 3.20E-12 3.20E-12 1.60E-10 1.10E-10 5.10E-11 3.30E-11 2.20E-11 1.80E-11 Nov. 23, 2020; 5:05 PM; 1,112 kB - C-14 5.80E-10 5.80E-10 5.80E-10 1.90E-08 1.70E-08 1.10E-08 7.40E-09 6.40E-09 5.80E-09 Correction TvD on June 12, 2021: Inhalation DCs for Member + C-14 5.80E-10 5.80E-10 5.80E-10 1.90E-08 1.70E-08 1.10E-08 7.40E-09 6.40E-09 5.80E-09 N-13 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 Column B is the selected column of data for the input file N-16 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 O-14 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 @@ -14,7 +14,7 @@ Nuclides ICRP-107 Used dataset: Worker, 5 EXT NUCL Worker, 1 ?m Worker, 5 ? F-18 9.30E-11 6.00E-11 9.30E-11 4.20E-10 3.10E-10 1.50E-10 1.00E-10 7.30E-11 5.90E-11 Ne-19 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 Ne-24 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 EXTENDED NUCLIDE LIST (EXTRA DATA FOR ADULTS ONLY!): - Na-22 2.00E-09 1.30E-09 2.00E-09 9.70E-09 7.30E-09 3.80E-09 2.40E-09 1.50E-09 1.30E-09 From Missing_nuclides_2.xlsx + Na-22 2.00E-09 1.30E-09 2.00E-09 9.70E-09 7.30E-09 3.80E-09 2.40E-09 1.50E-09 1.30E-09 Na-24 5.30E-10 2.90E-10 5.30E-10 2.30E-09 1.80E-09 9.30E-10 5.70E-10 3.40E-10 2.70E-10 WORKER DCs maximum values (Sv/Bq): Mg-27 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 0.00E+00 INHALATION 1/4/21 INH work Mg-28 1.70E-09 1.20E-09 1.70E-09 7.30E-09 7.20E-09 3.50E-09 2.30E-09 1.50E-09 1.20E-09 MISSING NUCLIDE 1 micron 5 micron val.CMO @@ -1255,9 +1255,9 @@ Nuclides ICRP-107 Used dataset: Worker, 5 EXT NUCL Worker, 1 ?m Worker, 5 ? -en_Ing\DC_InhIng_v8.xlsx -s of Public for nuclide S-35 (see: DC_InhIng_v9corr.xlsx from June 12, 2021; 5:09 PM) + + (selected from TAB Selection) diff --git a/src/lib/libcocktaildcc.f90 b/src/lib/libcocktaildcc.f90 index b43f0ad..ced00d3 100644 --- a/src/lib/libcocktaildcc.f90 +++ b/src/lib/libcocktaildcc.f90 @@ -1,4 +1,4 @@ -MODULE LibCocktailDCC +module LibCocktailDCC ! ____________________________________________________ ! ! Developed For: @@ -69,21 +69,21 @@ MODULE LibCocktailDCC ! ! After initialization, the names of the source terms can be found via the following string: ! - ! CHARACTER(DefaultLength), DIMENSION(MaxNSourceTerms) :: SourceTermName + ! character(DefaultLength), dimension(MaxNSourceTerms) :: SourceTermName ! ! ! To facilitate unambiguous specification of the different pathways for DCC, - ! we have defined the following set of INTEGER tags: + ! we have defined the following set of integer tags: ! - ! INTEGER, PARAMETER :: NPathways = 3 + ! integer, parameter :: NPathways = 3 ! - ! INTEGER, PARAMETER :: PathwayAir = 1 : submersion, i.e. external radiation alone - ! INTEGER, PARAMETER :: PathwayGround = 2 : external radiation from what is on the ground, assuming no penetration in the ground - ! INTEGER, PARAMETER :: PathwayInhalation = 3 : inhalation of particles, highest value is taken from available sizes + ! integer, parameter :: PathwayAir = 1 : submersion, i.e. external radiation alone + ! integer, parameter :: PathwayGround = 2 : external radiation from what is on the ground, assuming no penetration in the ground + ! integer, parameter :: PathwayInhalation = 3 : inhalation of particles, highest value is taken from available sizes ! ! and their names: ! - ! CHARACTER(10), DIMENSION(NPathways), PARAMETER :: PathwayName = & + ! character(10), dimension(NPathways), parameter :: PathwayName = & ! & (/'Air ',&! 1 ! & 'Ground ',&! 2 ! & 'Inhalation'/)! 3 @@ -93,212 +93,214 @@ MODULE LibCocktailDCC ! EDC_Viewer, August 16, 2020, which gives the external dose rate coefficients of ICRP Publication 144. ! ! To facilitate clear reference to either regular DCCs or cumulative DCCs, - ! we have defined the following set of INTEGER tags: + ! we have defined the following set of integer tags: ! - ! INTEGER, PARAMETER :: iRegularDCC = 1 - ! INTEGER, PARAMETER :: iCumulativeDCC = 2 + ! integer, parameter :: iRegularDCC = 1 + ! integer, parameter :: iCumulativeDCC = 2 ! ! and their names: ! - ! CHARACTER(13), DIMENSION(2), PARAMETER :: DCCTypeName = & + ! character(13), dimension(2), parameter :: DCCTypeName = & ! & (/'DCC ',&! 1 ! & 'CumulativeDCC'/)! 2 ! ! - ! Two REAL(Float) functions are the actual work horses of this library: + ! Two real(Float) functions are the actual work horses of this library: ! - ! FUNCTION GetCocktailDCC(x,iSourceTerm,iPathway,iType) + ! function GetCocktailDCC(x,iSourceTerm,iPathway,iType) ! This function gives the regular or cumulative cocktail-DCC for a given pathway, cocktail and delay after ! blast. The DCC is per 10kt. ! The following inputs should be specified: - ! REAL(Float), INTENT(IN) :: x = time in seconds since "blast" - ! INTEGER, INTENT(IN) :: iSourceTerm = tag specifying the nuclide vector at x=0 (options shown above) - ! INTEGER, INTENT(IN) :: iPathway = tag specifying the pathway (options shown above) - ! INTEGER, INTENT(IN) :: iType = tag specifying if you want to get the regular or the + ! real(Float), intent(in) :: x = time in seconds since "blast" + ! integer, intent(in) :: iSourceTerm = tag specifying the nuclide vector at x=0 (options shown above) + ! integer, intent(in) :: iPathway = tag specifying the pathway (options shown above) + ! integer, intent(in) :: iType = tag specifying if you want to get the regular or the ! cumulative DCC (options shown above) ! - ! FUNCTION GetCocktailNuclide(x,iSourceTerm,MyName) + ! function GetCocktailNuclide(x,iSourceTerm,MyName) ! This function gives the amount of a nuclide for a given cocktail and a given delay after blast. ! The amount is per 10kt. For irrelevant nuclides, 0.0 is returned and not an error message. ! Where: - ! REAL(Float), INTENT(IN) :: x = time in seconds since "blast" - ! INTEGER, INTENT(IN) :: iSourceTerm = tag specifying the nuclide vector at x=0 (options shown above) - ! CHARACTER(*), INTENT(IN) :: MyName = name of the nuclide you want to follow, e.g. 'I-131' or 'Cs137' + ! real(Float), intent(in) :: x = time in seconds since "blast" + ! integer, intent(in) :: iSourceTerm = tag specifying the nuclide vector at x=0 (options shown above) + ! character(*), intent(in) :: MyName = name of the nuclide you want to follow, e.g. 'I-131' or 'Cs137' ! ! ! An example of how to use libcocktaildcc can be found in test program test_cocktail_dcc.f90. ! - USE libxmath - USE libutil - USE libinterval - use libendf + use LibENDF, only: MaxNuclides, & + TransitionMatrixPath, MassNuc2NucMass + use LibInterval, only: ExponentialIntervalType, ExponentialIntervalInterpolate + use LibUtil, only: DefaultLength, ScratchFile, ScrotchFile,& + FileExists, & + AllUpCase, RemoveCharacter + use LibXMath, only: Float - IMPLICIT NONE + implicit none - PRIVATE - PUBLIC :: GetCocktailDCC,PathwayAir,PathwayGround,PathwayInhalation,NPathways,& + private + public :: GetCocktailDCC,PathwayAir,PathwayGround,PathwayInhalation,NPathways,& & NSourceTerms,SourceTermName,PathwayName, DCCTypeName,iRegularDCC,iCumulativeDCC,GetCocktailNuclide - INTEGER, PARAMETER :: PathwayAir = 1 - INTEGER, PARAMETER :: PathwayGround = 2 - INTEGER, PARAMETER :: PathwayInhalation = 3 + integer, parameter :: PathwayAir = 1 + integer, parameter :: PathwayGround = 2 + integer, parameter :: PathwayInhalation = 3 - INTEGER, PARAMETER :: NPathways = 3 + integer, parameter :: NPathways = 3 - INTEGER, PARAMETER :: MaxNSourceTerms = 10 - INTEGER :: NSourceTerms = 0 + integer, parameter :: MaxNSourceTerms = 10 + integer :: NSourceTerms = 0 - LOGICAL :: LibCocktailDCCInitialized = .FALSE. + logical :: LibCocktailDCCInitialized = .FALSE. - INTEGER, PARAMETER :: iRegularDCC = 1 - INTEGER, PARAMETER :: iCumulativeDCC = 2 + integer, parameter :: iRegularDCC = 1 + integer, parameter :: iCumulativeDCC = 2 - CHARACTER(13), DIMENSION(2), PARAMETER :: DCCTypeName = & - & (/'DCC ',&! 1 - & 'CumulativeDCC'/)! 2 + character(13), dimension(2), parameter :: DCCTypeName = & + & ['DCC ',&! 1 + & 'CumulativeDCC']! 2 - TYPE(ExponentialIntervalType), DIMENSION(MaxNSourceTerms,NPathways,iRegularDCC:iCumulativeDCC) :: CocktailDCC - TYPE(ExponentialIntervalType), DIMENSION(MaxNSourceTerms,MaxNuclides) :: LookupCocktail - CHARACTER(10), DIMENSION(MaxNSourceTerms,MaxNuclides) :: MyNuclideName - INTEGER, DIMENSION(MaxNSourceTerms) :: NContributingNuclides + type(ExponentialIntervalType), dimension(MaxNSourceTerms,NPathways,iRegularDCC:iCumulativeDCC) :: CocktailDCC + type(ExponentialIntervalType), dimension(MaxNSourceTerms,MaxNuclides) :: LookupCocktail + character(10), dimension(MaxNSourceTerms,MaxNuclides) :: MyNuclideName + integer, dimension(MaxNSourceTerms) :: NContributingNuclides - CHARACTER(DefaultLength), DIMENSION(MaxNSourceTerms) :: SourceTermName + character(DefaultLength), dimension(MaxNSourceTerms) :: SourceTermName - CHARACTER(10), DIMENSION(NPathways), PARAMETER :: PathwayName = & - & (/'Air ',&! 1 - & 'Ground ',&! 2 - & 'Inhalation'/)! 3 + character(10), dimension(NPathways), parameter :: PathwayName = & + & ['Air ',&! 1 + & 'Ground ',&! 2 + & 'Inhalation']! 3 -CONTAINS - SUBROUTINE InitLibCocktailDCC() +contains + subroutine InitLibCocktailDCC() ! ! Read the list of source terms and check availability of lookup tables. ! Add missing lookup tables. ! use LibENDF, only: RIVMSourcesPath - LOGICAL, PARAMETER :: CrashOnError = .FALSE.,DoSilent = .FALSE. - CHARACTER(DefaultLength) :: ALine,SourceFileName,CheckLookupFileName,Commando,FName,UtilityName - INTEGER :: TheIndex,Error + character(DefaultLength) :: ALine,SourceFileName,CheckLookupFileName,Commando,FName,UtilityName + integer :: TheIndex,Error - INTEGER, PARAMETER :: DebugLevel = 1 + integer, parameter :: DebugLevel = 1 - WRITE(*,'(A)') '--------------------------------------------------------------' - WRITE(*,*) - WRITE(*,'(A)') 'Going to initialize libcocktailDCC...' - WRITE(*,*) + write(*,'(A)') '--------------------------------------------------------------' + write(*,*) + write(*,'(A)') 'Going to initialize libcocktailDCC...' + write(*,*) FName = RIVMSourcesPath() // '/RIVMSources.txt' - IF (.NOT.FileExists(FName)) THEN - WRITE(*,'(A)') 'Cannot find list of source term files "'//TRIM(FName)//'"' - ENDIF + if (.NOT.FileExists(FName)) then + write(*,'(A)') 'Cannot find list of source term files "'//trim(FName)//'"' + endif - IF (DebugLevel.GT.0) WRITE(*,'(A)') 'Reading list of source terms from file '//TRIM(FName) + if (DebugLevel > 0) write(*,'(A)') 'Reading list of source terms from file '//trim(FName) - OPEN(ScrotchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + open(ScrotchFile,file=FName,form='FORMATTED',action='READ') ! ! Skip header ! - READ(ScrotchFile,'(A)') ALine - DO WHILE (ALine(1:1).EQ.'!') - READ(ScrotchFile,'(A)') ALine - ENDDO ! skip header + read(ScrotchFile,'(A)') ALine + do while (ALine(1:1) == '!') + read(ScrotchFile,'(A)') ALine + enddo ! skip header ! ! Read source term names and check lookup tables. Add new lookup tables where necessary. ! NSourceTerms = 0 - DO WHILE (NSourceTerms.LT.MaxNSourceTerms) + do while (NSourceTerms < MaxNSourceTerms) ! ! Read source file name ! - READ(Aline,'(A)',END=10) SourceFileName + read(Aline,'(A)',end=10) SourceFileName NSourceTerms = NSourceTerms + 1 - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,I0,A)') 'Source term ',NSourceTerms,' is '//TRIM(SourceFileName) - IF (NSourceTerms.EQ.MaxNSourceTerms) WRITE(*,'(A,I0,A)') 'I Reached the maximum number of sources: ',& + if (DebugLevel > 0) then + write(*,'(A,I0,A)') 'Source term ',NSourceTerms,' is '//trim(SourceFileName) + if (NSourceTerms == MaxNSourceTerms) write(*,'(A,I0,A)') 'I Reached the maximum number of sources: ',& & MaxNSourceTerms,'! Subsequent sources will not be read!' - ENDIF + endif ! ! Check if name suggests format .RIVMSource ! TheIndex = INDEX(SourceFileName,'.RIVMSource') - IF (TheIndex.EQ.0) THEN - WRITE(*,'(A)') 'Source term "'//TRIM(SourceFileName)//'" is not of type .RIVMSource! Exiting!!' - CALL EXIT() - ELSE - IF (DebugLevel.GT.1) WRITE(*,'(A,I0)') 'Extension .RIVMSource starts at position ',TheIndex - ENDIF + if (TheIndex == 0) then + write(*,'(A)') 'Source term "'//trim(SourceFileName)//'" is not of type .RIVMSource! Exiting!!' + call exit() + else + if (DebugLevel > 1) write(*,'(A,I0)') 'Extension .RIVMSource starts at position ',TheIndex + endif SourceTermName(NSourceTerms) = SourceFileName(1:(TheIndex-1)) - IF (DebugLevel.GT.1) WRITE(*,'(A)') 'Name of source term is "'//TRIM(SourceTermName(NSourceTerms))//'"' - DO WHILE (INDEX(SourceTermName(NSourceTerms),'/').GT.0) + if (DebugLevel > 1) write(*,'(A)') 'Name of source term is "'//trim(SourceTermName(NSourceTerms))//'"' + do while (INDEX(SourceTermName(NSourceTerms),'/') > 0) SourceTermName(NSourceTerms) = SourceTermName(NSourceTerms) & - & ((INDEX(SourceTermName(NSourceTerms),'/')+1):LEN_TRIM(SourceTermName(NSourceTerms))) - IF (DebugLevel.GT.1) WRITE(*,'(A)') 'Name of source term is "'//TRIM(SourceTermName(NSourceTerms))//'"' - ENDDO - IF (DebugLevel.GT.1) WRITE(*,'(A)') 'Name of source term is "'//TRIM(SourceTermName(NSourceTerms))//'"' + & ((INDEX(SourceTermName(NSourceTerms),'/')+1):len_trim(SourceTermName(NSourceTerms))) + if (DebugLevel > 1) write(*,'(A)') 'Name of source term is "'//trim(SourceTermName(NSourceTerms))//'"' + enddo + if (DebugLevel > 1) write(*,'(A)') 'Name of source term is "'//trim(SourceTermName(NSourceTerms))//'"' ! ! Check existence of lookup tables. If not available, add new lookup tables. ! CheckLookupFileName = SourceFileName(1:(TheIndex-1))//'_PinpointAirDoseRates_withprogeny.txt' - IF (.NOT.FileExists(CheckLookupFileName)) THEN - IF (DebugLevel.GT.0) WRITE(*,'(A)') 'Cannot find associated lookup tables. Adding new tables...' + if (.NOT.FileExists(CheckLookupFileName)) then + if (DebugLevel > 0) write(*,'(A)') 'Cannot find associated lookup tables. Adding new tables...' Commando = 'runlog??.txt' - WRITE(Commando(7:8),'(I2.2)') NSourceTerms + write(Commando(7:8),'(I2.2)') NSourceTerms UtilityName = './build/src/source_term_dose' - IF (.NOT.FileExists(UtilityName)) THEN - WRITE(*,'(A)') 'Cannot find utility '//TRIM(UtilityName)//' and its auxiliary files... Exiting!' - CALL EXIT() - ENDIF ! utility not found - Commando = TRIM(UtilityName)//' '//TRIM(SourceFileName)//' yes 0 0 > ' & - & // TransitionMatrixPath() // '/' // TRIM(Commando) + if (.NOT.FileExists(UtilityName)) then + write(*,'(A)') 'Cannot find utility '//trim(UtilityName)//' and its auxiliary files... Exiting!' + call exit() + endif ! utility not found + Commando = trim(UtilityName)//' '//trim(SourceFileName)//' yes 0 0 > ' & + & // TransitionMatrixPath() // '/' // trim(Commando) Error = SYSTEM(Commando) - IF (Error.EQ.0) THEN - WRITE(*,'(A)') 'Execution of external call "'//TRIM(Commando)//'" went well!' - ELSE - WRITE(*,'(A)') 'Execution of external call "'//TRIM(Commando)//'" went wrong! Exiting' - CALL EXIT() - ENDIF - ELSE - IF (DebugLevel.GT.0) WRITE(*,'(A)') 'Found associated lookup tables!' - ENDIF + if (Error == 0) then + write(*,'(A)') 'Execution of external call "'//trim(Commando)//'" went well!' + else + write(*,'(A)') 'Execution of external call "'//trim(Commando)//'" went wrong! Exiting' + call exit() + endif + else + if (DebugLevel > 0) write(*,'(A)') 'Found associated lookup tables!' + endif ! ! Read lookup tables for this source term ! - CALL InitializeCocktailDCC(SourceFileName,NSourceTerms) - CALL InitializeCocktail(SourceFileName,NSourceTerms) + call InitializeCocktailDCC(SourceFileName,NSourceTerms) + call InitializeCocktail(SourceFileName,NSourceTerms) - READ(ScrotchFile,'(A)',END=10) ALine - ENDDO ! Loop over all source terms declared + read(ScrotchFile,'(A)',end=10) ALine + enddo ! Loop over all source terms declared - 10 CONTINUE - CLOSE(ScrotchFile) + 10 continue + close(ScrotchFile) LibCocktailDCCInitialized = .TRUE. - WRITE(*,'(A)') 'Ready initializing libcocktailDCC!' - WRITE(*,*) - WRITE(*,'(A)') '--------------------------------------------------------------' - END SUBROUTINE InitLibCocktailDCC + write(*,'(A)') 'Ready initializing libcocktailDCC!' + write(*,*) + write(*,'(A)') '--------------------------------------------------------------' + end subroutine InitLibCocktailDCC - SUBROUTINE MakeCumulativeCocktailDCC(iSourceTerm) + subroutine MakeCumulativeCocktailDCC(iSourceTerm) ! ! Construct cumulative cocktailDCC in Sv (plus the SI dimensions of the volume or surface) ! - INTEGER, INTENT(IN) :: iSourceTerm + integer, intent(in) :: iSourceTerm - INTEGER :: iPathway,iPinpoint - REAL(Float) :: tLeft,tRight,dDCC,dt + integer :: iPathway,iPinpoint + real(Float) :: tLeft,tRight,dDCC,dt - DO iPathway = 1,NPathways + do iPathway = 1,NPathways CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%IntervalSpecs = & & CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%IntervalSpecs CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%FirstDelay = & @@ -306,14 +308,14 @@ SUBROUTINE MakeCumulativeCocktailDCC(iSourceTerm) CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%DelayGrowthFactor = & & CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%DelayGrowthFactor - ALLOCATE(CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%Values(& + allocate(CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%Values(& & 0:CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%IntervalSpecs%N)) CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%Values = 0._Float tLeft = 0._Float tRight = CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%FirstDelay - DO iPinpoint = 1,CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%IntervalSpecs%N + do iPinpoint = 1,CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%IntervalSpecs%N ! ! Trapezium rule based on linear interpolation (which should be fair when GrowthFactor is not too far from 1) ! @@ -326,49 +328,49 @@ SUBROUTINE MakeCumulativeCocktailDCC(iSourceTerm) tLeft = tRight tRight = tLeft * CocktailDCC(iSourceTerm,iPathway,iCumulativeDCC)%DelayGrowthFactor - ENDDO ! loop over pinpoints - ENDDO ! loop over pathways - END SUBROUTINE MakeCumulativeCocktailDCC + enddo ! loop over pinpoints + enddo ! loop over pathways + end subroutine MakeCumulativeCocktailDCC - SUBROUTINE InitializeCocktailDCC(SourceFileName,iSourceTerm) + subroutine InitializeCocktailDCC(SourceFileName,iSourceTerm) ! ! Load the lookup tables for the cocktail DCCs in Sv/s (plus the SI dimensions of the volume or surface) ! - CHARACTER(*), INTENT(IN) :: SourceFileName - INTEGER, INTENT(IN) :: iSourceTerm + character(*), intent(in) :: SourceFileName + integer, intent(in) :: iSourceTerm - INTEGER :: iPathway,iPinpoint,MyPinpoint,TheIndex - CHARACTER(DefaultLength) :: FName,DumStr - REAL(Float) :: Dum + integer :: iPathway,iPinpoint,MyPinpoint,TheIndex + character(DefaultLength) :: FName,DumStr + real(Float) :: Dum - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 TheIndex = INDEX(SourceFileName,'.RIVMSource') - DO iPathway = 1,NPathways + do iPathway = 1,NPathways ! ! Open file ! - FName = SourceFileName(1:(TheIndex-1))//'_Pinpoint'//TRIM(PathwayName(iPathway))//'DoseRates_withprogeny.txt' + FName = SourceFileName(1:(TheIndex-1))//'_Pinpoint'//trim(PathwayName(iPathway))//'DoseRates_withprogeny.txt' - IF (.NOT.FileExists(FName)) THEN - WRITE(*,'(A)') 'Cannot find lookup table file '//TRIM(FName)//', exiting!' - CALL EXIT() - ELSE - WRITE(*,'(A)') 'Going to read lookup table file '//TRIM(FName)//'...' - ENDIF + if (.NOT.FileExists(FName)) then + write(*,'(A)') 'Cannot find lookup table file '//trim(FName)//', exiting!' + call exit() + else + write(*,'(A)') 'Going to read lookup table file '//trim(FName)//'...' + endif - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + open(ScratchFile,file=FName,form='FORMATTED',action='READ') ! ! Skip header ! - READ(ScratchFile,*) + read(ScratchFile,*) ! ! Extract interval specs and allocate array ! - READ(ScratchFile,*) DumStr,CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%FirstDelay,& + read(ScratchFile,*) DumStr,CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%FirstDelay,& & DumStr,CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%DelayGrowthFactor,& & DumStr,CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%IntervalSpecs%N @@ -378,34 +380,34 @@ SUBROUTINE InitializeCocktailDCC(SourceFileName,iSourceTerm) & * (CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%DelayGrowthFactor)& & **CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%IntervalSpecs%N - ALLOCATE(CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%Values(& + allocate(CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%Values(& & 0:CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%IntervalSpecs%N)) ! ! Skip header ! - READ(ScratchFile,*) + read(ScratchFile,*) ! ! Read actual cocktail DCCs ! - DO iPinpoint = 0,CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%IntervalSpecs%N - READ(ScratchFile,*) MyPinpoint,Dum,CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%Values(iPinpoint) - IF (DebugLevel.GT.0) WRITE(*,'(A,I3,A,I3)') 'Pinpoint=',iPinpoint,', MyPinpoint=',MyPinpoint - ENDDO ! loop over pinpoints + do iPinpoint = 0,CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%IntervalSpecs%N + read(ScratchFile,*) MyPinpoint,Dum,CocktailDCC(iSourceTerm,iPathway,iRegularDCC)%Values(iPinpoint) + if (DebugLevel > 0) write(*,'(A,I3,A,I3)') 'Pinpoint=',iPinpoint,', MyPinpoint=',MyPinpoint + enddo ! loop over pinpoints ! ! Close file ! - CLOSE(ScratchFile) + close(ScratchFile) - ENDDO ! loop over pathways + enddo ! loop over pathways ! ! Construct cumulative cocktailDCC ! - CALL MakeCumulativeCocktailDCC(iSourceTerm) - END SUBROUTINE InitializeCocktailDCC + call MakeCumulativeCocktailDCC(iSourceTerm) + end subroutine InitializeCocktailDCC - FUNCTION GetCocktailDCC(x,iSourceTerm,iPathway,iType) + function GetCocktailDCC(x,iSourceTerm,iPathway,iType) ! ! Give the ! regular or cumulative (iType) @@ -415,45 +417,45 @@ FUNCTION GetCocktailDCC(x,iSourceTerm,iPathway,iType) ! and a given delay x [seconds] after start cocktail ! The DCC is per 10kt. ! - REAL(Float), INTENT(IN) :: x - INTEGER, INTENT(IN) :: iSourceTerm,iPathway,iType - REAL(Float) :: GetCocktailDCC + real(Float), intent(in) :: x + integer, intent(in) :: iSourceTerm,iPathway,iType + real(Float) :: GetCocktailDCC - INTEGER, PARAMETER :: InterpolationWay = 1 ! First order interpolation - LOGICAL :: Error - REAL(Float) :: Dum + integer, parameter :: InterpolationWay = 1 ! First order interpolation + logical :: Error + real(Float) :: Dum - IF (.NOT.LibCocktailDCCInitialized) CALL InitLibCocktailDCC() + if (.NOT.LibCocktailDCCInitialized) call InitLibCocktailDCC() - IF ((iSourceTerm.LT.1).OR.(iSourceTerm.GT.NSourceTerms)) THEN - WRITE(*,'(A,I0,A)') 'Invalid source term index: ',iSourceTerm,'! Exiting!!' - CALL EXIT() - ENDIF ! + if ((iSourceTerm < 1).OR.(iSourceTerm > NSourceTerms)) then + write(*,'(A,I0,A)') 'Invalid source term index: ',iSourceTerm,'! Exiting!!' + call exit() + endif ! Dum = ExponentialIntervalInterpolate(x,CocktailDCC(iSourceTerm,iPathway,iType),InterpolationWay,Error) - IF (Error) THEN - WRITE(*,'(A,G15.5,A,I0,A,I0,A,I0)') 'GetCocktailDCC: Error for x=',x,& + if (Error) then + write(*,'(A,G15.5,A,I0,A,I0,A,I0)') 'GetCocktailDCC: Error for x=',x,& & ', iSourceTerm=',iSourceTerm,', iPathway=',iPathway,', iType=',iType - WRITE(*,'(A)') 'Exiting!!' - CALL EXIT() - ENDIF + write(*,'(A)') 'Exiting!!' + call exit() + endif GetCocktailDCC = Dum - END FUNCTION GetCocktailDCC + end function GetCocktailDCC - SUBROUTINE InitializeCocktail(SourceFileName,iSourceTerm) + subroutine InitializeCocktail(SourceFileName,iSourceTerm) ! ! Load the lookup tables for the cocktails in Bq ! - CHARACTER(*), INTENT(IN) :: SourceFileName - INTEGER, INTENT(IN) :: iSourceTerm + character(*), intent(in) :: SourceFileName + integer, intent(in) :: iSourceTerm - INTEGER :: iPathway,iPinpoint,MyPinpoint,PinpointN,iNuclide,TheIndex - CHARACTER(DefaultLength) :: FName,DumStr - REAL(Float) :: Dum,PinpointFirstDelay,PinpointDelayGrowthFactor + integer :: iPinpoint,MyPinpoint,PinpointN,iNuclide,TheIndex + character(DefaultLength) :: FName,DumStr + real(Float) :: Dum,PinpointFirstDelay,PinpointDelayGrowthFactor - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 ! ! Open file ! @@ -461,23 +463,23 @@ SUBROUTINE InitializeCocktail(SourceFileName,iSourceTerm) FName = SourceFileName(1:(TheIndex-1))//'_PinpointCocktail_withprogeny.txt' - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + open(ScratchFile,file=FName,form='FORMATTED',action='READ') ! ! Extract interval specs and allocate array ! - READ(ScratchFile,*) DumStr,PinpointFirstDelay,& + read(ScratchFile,*) DumStr,PinpointFirstDelay,& & DumStr,PinpointDelayGrowthFactor,& & DumStr,PinpointN ! ! Find out which nuclides are contributing this time and initialize lookup tables for them ! - READ(ScratchFile,*) NContributingNuclides(iSourceTerm) + read(ScratchFile,*) NContributingNuclides(iSourceTerm) - READ(ScratchFile,*) DumStr,DumStr,(MyNuclideName(iSourceTerm,iNuclide),iNuclide=1,NContributingNuclides(iSourceTerm)) + read(ScratchFile,*) DumStr,DumStr,(MyNuclideName(iSourceTerm,iNuclide),iNuclide=1,NContributingNuclides(iSourceTerm)) - DO iNuclide=1,NContributingNuclides(iSourceTerm) - CALL AllUpCase(MyNuclideName(iSourceTerm,iNuclide)) - CALL RemoveCharacter(MyNuclideName(iSourceTerm,iNuclide),'-') + do iNuclide=1,NContributingNuclides(iSourceTerm) + call AllUpCase(MyNuclideName(iSourceTerm,iNuclide)) + call RemoveCharacter(MyNuclideName(iSourceTerm,iNuclide),'-') LookupCocktail(iSourceTerm,iNuclide)%FirstDelay = PinpointFirstDelay LookupCocktail(iSourceTerm,iNuclide)%DelayGrowthFactor = PinpointDelayGrowthFactor @@ -488,77 +490,77 @@ SUBROUTINE InitializeCocktail(SourceFileName,iSourceTerm) & * (LookupCocktail(iSourceTerm,iNuclide)%DelayGrowthFactor)& & **LookupCocktail(iSourceTerm,iNuclide)%IntervalSpecs%N - ALLOCATE(LookupCocktail(iSourceTerm,iNuclide)%Values(0:PinpointN)) - ENDDO ! loop over contributing nuclides + allocate(LookupCocktail(iSourceTerm,iNuclide)%Values(0:PinpointN)) + enddo ! loop over contributing nuclides ! ! Read actual cocktail ! - DO iPinpoint = 0,PinpointN - READ(ScratchFile,*) MyPinpoint,Dum,& + do iPinpoint = 0,PinpointN + read(ScratchFile,*) MyPinpoint,Dum,& & (LookupCocktail(iSourceTerm,iNuclide)%Values(iPinpoint),iNuclide=1,NContributingNuclides(iSourceTerm)) - IF (DebugLevel.GT.0) WRITE(*,'(A,I3,A,I3)') 'Pinpoint=',iPinpoint,', MyPinpoint=',MyPinpoint - ENDDO ! loop over pinpoints + if (DebugLevel > 0) write(*,'(A,I3,A,I3)') 'Pinpoint=',iPinpoint,', MyPinpoint=',MyPinpoint + enddo ! loop over pinpoints ! ! Close file ! - CLOSE(ScratchFile) - END SUBROUTINE InitializeCocktail + close(ScratchFile) + end subroutine InitializeCocktail - FUNCTION GetCocktailNuclide(x,iSourceTerm,MyName) + function GetCocktailNuclide(x,iSourceTerm,MyName) ! ! Give the amount of a nuclide for a given cocktail (iSourceTerm) ! and a given delay x [seconds] after start cocktail. ! The amount is per 10kt. ! - REAL(Float), INTENT(IN) :: x - INTEGER, INTENT(IN) :: iSourceTerm - CHARACTER(*), INTENT(IN) :: MyName - REAL(Float) :: GetCocktailNuclide - - INTEGER, PARAMETER :: InterpolationWay = 1 ! First order interpolation - LOGICAL :: Error,Ready - REAL(Float) :: Dum - INTEGER :: iNuclide,TheNuclide - CHARACTER(10) :: UpName - - IF (.NOT.LibCocktailDCCInitialized) CALL InitLibCocktailDCC() - - IF ((iSourceTerm.LT.1).OR.(iSourceTerm.GT.NSourceTerms)) THEN - WRITE(*,'(A,I0,A)') 'Invalid source term index: ',iSourceTerm,'! Exiting!!' - CALL EXIT() - ENDIF + real(Float), intent(in) :: x + integer, intent(in) :: iSourceTerm + character(*), intent(in) :: MyName + real(Float) :: GetCocktailNuclide + + integer, parameter :: InterpolationWay = 1 ! First order interpolation + logical :: Error,Ready + real(Float) :: Dum + integer :: iNuclide,TheNuclide + character(10) :: UpName + + if (.NOT.LibCocktailDCCInitialized) call InitLibCocktailDCC() + + if ((iSourceTerm < 1).OR.(iSourceTerm > NSourceTerms)) then + write(*,'(A,I0,A)') 'Invalid source term index: ',iSourceTerm,'! Exiting!!' + call exit() + endif ! ! Identify the nuclide. If found, the give value via lookup, ! otherwise return 0 as the nuclide apparently does not participate. ! UpName = MyName - CALL MassNuc2NucMass(UpName) - CALL AllUpCase(UpName) - CALL RemoveCharacter(UpName,'-') + call MassNuc2NucMass(UpName) + call AllUpCase(UpName) + call RemoveCharacter(UpName,'-') TheNuclide = 0 iNuclide = 0 Ready = .FALSE. - DO WHILE((.NOT.Ready).AND.(iNuclide.LT.MaxNuclides)) + do while((.NOT.Ready).AND.(iNuclide < MaxNuclides)) iNuclide = iNuclide + 1 - IF (TRIM(UpName).EQ.TRIM(MyNuclideName(iSourceTerm,iNuclide))) THEN + if (trim(UpName) == trim(MyNuclideName(iSourceTerm,iNuclide))) then TheNuclide = iNuclide - ENDIF - ENDDO ! loop over nuclides + endif + enddo ! loop over nuclides - IF (TheNuclide.EQ.0) THEN + if (TheNuclide == 0) then Dum = 0._Float - ELSE + else Dum = ExponentialIntervalInterpolate(x,LookupCocktail(iSourceTerm,TheNuclide),InterpolationWay,Error) - IF (Error) THEN - WRITE(*,'(A,G15.5,A,I0,A,I0,A,I0,A,A)') 'GetCocktailNuclide: Error for x=',x,& - & ', iSourceTerm=',iSourceTerm,', iNuclide=',TheNuclide,' for nuclide named ',TRIM(MyName) - WRITE(*,'(A)') 'Exiting!!' - CALL EXIT() - ENDIF ! error - ENDIF ! nuclide recognized + if (Error) then + write(*,'(A,G15.5,A,I0,A,I0,A,I0,A,A)') 'GetCocktailNuclide: Error for x=',x,& + & ', iSourceTerm=',iSourceTerm,', iNuclide=',TheNuclide,' for nuclide named ',trim(MyName) + write(*,'(A)') 'Exiting!!' + call exit() + endif ! error + endif ! nuclide recognized GetCocktailNuclide = Dum - END FUNCTION GetCocktailNuclide -END MODULE LibCocktailDCC + end function GetCocktailNuclide +end module LibCocktailDCC diff --git a/src/lib/libdcc.f90 b/src/lib/libdcc.f90 index f2ae469..853d12c 100644 --- a/src/lib/libdcc.f90 +++ b/src/lib/libdcc.f90 @@ -1,4 +1,4 @@ -MODULE LibDCC +module LibDCC ! ____________________________________________________ ! ! Developed For: @@ -11,62 +11,63 @@ MODULE LibDCC ! The Netherlands ! ____________________________________________________ ! - USE libxmath - USE libutil - USE libendf - use LibENDF, only: RIVMSourcesPath, isGas - IMPLICIT NONE + use LibENDF, only: RIVMSourcesPath, isGas, & + ReadNProcessENDFNuclideSpecs, ReadNuclideSpecs, NuclideSpecs, GetNuclideNumber, NuclideType, MaxNuclides + use LibUtil, only: DefaultLength, ScratchFile, & + Male, Female, GenderName + use LibXMath, only: Float + implicit none - PRIVATE + private - PUBLIC :: InitLibDCC,ReadTissueDCCs,ReadDCCEffectiveDose,ReadGroundDCCs,DCCEffectiveDose,DCCGround,& + public :: InitLibDCC,ReadTissueDCCs,ReadDCCEffectiveDose,ReadGroundDCCs,DCCEffectiveDose,DCCGround,& & InAir,Age_Adult,DCCInhalation,ReadInhalationDCCs,Inhalation_public_adult,& & DCCThyroidInhalation,ReadThyroidInhalationDCCs - CHARACTER(DefaultLength) :: ProjectPath = './' + character(DefaultLength) :: ProjectPath = './' - CHARACTER(DefaultLength) :: DCCAirSubmersionPath,DCCSoilContaminationPath,DCCWaterImmersionPath,& + character(DefaultLength) :: DCCAirSubmersionPath,DCCSoilContaminationPath,DCCWaterImmersionPath,& & DCCInhalationPath logical :: OPTION_NobleGroundShine = .False. - INTEGER, PARAMETER :: InAir = 1 - INTEGER, PARAMETER :: InWater = 2 - - INTEGER, PARAMETER :: Tissue_R_marrow = 1 - INTEGER, PARAMETER :: Tissue_Colon = 2 - INTEGER, PARAMETER :: Tissue_Lungs = 3 - INTEGER, PARAMETER :: Tissue_ST_wall = 4 - INTEGER, PARAMETER :: Tissue_Breast = 5 - INTEGER, PARAMETER :: Tissue_Ovaries = 6 - INTEGER, PARAMETER :: Tissue_Testes = 7 - INTEGER, PARAMETER :: Tissue_UB_wall = 8 - INTEGER, PARAMETER :: Tissue_Oesophagus = 9 - INTEGER, PARAMETER :: Tissue_Liver = 10 - INTEGER, PARAMETER :: Tissue_Thyroid = 11 - INTEGER, PARAMETER :: Tissue_Endost_BS = 12 - INTEGER, PARAMETER :: Tissue_Brain = 13 - INTEGER, PARAMETER :: Tissue_S_glands = 14 - INTEGER, PARAMETER :: Tissue_Skin = 15 - INTEGER, PARAMETER :: Tissue_Adrenals = 16 - INTEGER, PARAMETER :: Tissue_ET = 17 - INTEGER, PARAMETER :: Tissue_GB_wall = 18 - INTEGER, PARAMETER :: Tissue_Ht_wall = 19 - INTEGER, PARAMETER :: Tissue_Kidneys = 20 - INTEGER, PARAMETER :: Tissue_Lymph = 21 - INTEGER, PARAMETER :: Tissue_Muscle = 22 - INTEGER, PARAMETER :: Tissue_O_mucosa = 23 - INTEGER, PARAMETER :: Tissue_Pancreas = 24 - INTEGER, PARAMETER :: Tissue_Prostate = 25 - INTEGER, PARAMETER :: Tissue_SI_wall = 26 - INTEGER, PARAMETER :: Tissue_Spleen = 27 - INTEGER, PARAMETER :: Tissue_Thymus = 28 - INTEGER, PARAMETER :: Tissue_Uterus = 29 - - INTEGER, PARAMETER :: NTissues = 29 - - CHARACTER(10), PARAMETER, DIMENSION(NTissues) :: TissueName = & - & (/'R-marrow ',& + integer, parameter :: InAir = 1 + integer, parameter :: InWater = 2 + + integer, parameter :: Tissue_R_marrow = 1 + integer, parameter :: Tissue_Colon = 2 + integer, parameter :: Tissue_Lungs = 3 + integer, parameter :: Tissue_ST_wall = 4 + integer, parameter :: Tissue_Breast = 5 + integer, parameter :: Tissue_Ovaries = 6 + integer, parameter :: Tissue_Testes = 7 + integer, parameter :: Tissue_UB_wall = 8 + integer, parameter :: Tissue_Oesophagus = 9 + integer, parameter :: Tissue_Liver = 10 + integer, parameter :: Tissue_Thyroid = 11 + integer, parameter :: Tissue_Endost_BS = 12 + integer, parameter :: Tissue_Brain = 13 + integer, parameter :: Tissue_S_glands = 14 + integer, parameter :: Tissue_Skin = 15 + integer, parameter :: Tissue_Adrenals = 16 + integer, parameter :: Tissue_ET = 17 + integer, parameter :: Tissue_GB_wall = 18 + integer, parameter :: Tissue_Ht_wall = 19 + integer, parameter :: Tissue_Kidneys = 20 + integer, parameter :: Tissue_Lymph = 21 + integer, parameter :: Tissue_Muscle = 22 + integer, parameter :: Tissue_O_mucosa = 23 + integer, parameter :: Tissue_Pancreas = 24 + integer, parameter :: Tissue_Prostate = 25 + integer, parameter :: Tissue_SI_wall = 26 + integer, parameter :: Tissue_Spleen = 27 + integer, parameter :: Tissue_Thymus = 28 + integer, parameter :: Tissue_Uterus = 29 + + integer, parameter :: NTissues = 29 + + character(10), parameter, dimension(NTissues) :: TissueName = & + & ['R-marrow ',& & 'Colon ',& & 'Lungs ',& & 'ST-wall ',& @@ -94,29 +95,21 @@ MODULE LibDCC & 'SI-wall ',& & 'Spleen ',& & 'Thymus ',& - & 'Uterus '/) + & 'Uterus '] - INTEGER, PARAMETER :: Age_Adult = 1 - INTEGER, PARAMETER :: Age_15yr = 2 - INTEGER, PARAMETER :: Age_10yr = 3 - INTEGER, PARAMETER :: Age_5yr = 4 - INTEGER, PARAMETER :: Age_1yr = 5 - INTEGER, PARAMETER :: Age_Newborn = 6 + integer, parameter :: Age_Adult = 1 + integer, parameter :: Age_15yr = 2 + integer, parameter :: Age_10yr = 3 + integer, parameter :: Age_5yr = 4 + integer, parameter :: Age_1yr = 5 + integer, parameter :: Age_Newborn = 6 - INTEGER, PARAMETER :: NDCCAges = 6 + integer, parameter :: NDCCAges = 6 - CHARACTER(7), PARAMETER, DIMENSION(NDCCAges) :: DCCAgeName = & - & (/'Adult ',& - & '15yr ',& - & '10yr ',& - & '5yr ',& - & '1yr ',& - & 'Newborn'/) + integer, parameter :: NGroundDepths = 9 - INTEGER, PARAMETER :: NGroundDepths = 9 - - CHARACTER(45), PARAMETER, DIMENSION(NGroundDepths) :: GroundDepthName = & - & (/'Planar sources at specific depths/0.5 g.cm-2/',& + character(45), parameter, dimension(NGroundDepths) :: GroundDepthName = & + & ['Planar sources at specific depths/0.5 g.cm-2/',& & 'Exponential sources/0.5 g.cm-2/ ',& & 'Exponential sources/1.0 g.cm-2/ ',& & 'Exponential sources/2.5 g.cm-2/ ',& @@ -124,62 +117,50 @@ MODULE LibDCC & 'Exponential sources/10.0 g.cm-2/ ',& & 'Exponential sources/20.0 g.cm-2/ ',& & 'Exponential sources/50.0 g.cm-2/ ',& - & 'Exponential sources/100.0 g.cm-2/ '/) - - INTEGER, PARAMETER :: NInhalationDCCs = 8 - - INTEGER, PARAMETER :: Inhalation_worker_1um = 1 - INTEGER, PARAMETER :: Inhalation_worker_5um = 2 - INTEGER, PARAMETER :: Inhalation_public_infant = 3 - INTEGER, PARAMETER :: Inhalation_public_1_year = 4 - INTEGER, PARAMETER :: Inhalation_public_5_year = 5 - INTEGER, PARAMETER :: Inhalation_public_10_year = 6 - INTEGER, PARAMETER :: Inhalation_public_15_year = 7 - INTEGER, PARAMETER :: Inhalation_public_adult = 8 - - CHARACTER(14), PARAMETER, DIMENSION(NInhalationDCCs) :: InhalationDCCName = & - & (/'worker 1um ',& - & 'worker 5um ',& - & 'public infant ',& - & 'public 1 year ',& - & 'public 5 year ',& - & 'public 10 year',& - & 'public 15 year',& - & 'public adult '/) - - TYPE DCCVector - REAL(Float), DIMENSION(MaxNuclides) :: x - END TYPE DCCVector - - TYPE(DCCVector), DIMENSION(InAir:InWater,Male:Female,NTissues,NDCCAges) :: DCCTissue - TYPE(DCCVector), DIMENSION(NGroundDepths,NDCCAges) :: DCCGround - TYPE(DCCVector), DIMENSION(NGroundDepths) :: DCCEquivalentDoseGround,DCCKermaRateGround - TYPE(DCCVector), DIMENSION(InAir:InWater,NDCCAges) :: DCCEffectiveDose - TYPE(DCCVector) :: DCCEquivalentDoseInAir,DCCKermaRateInAir,DCCThyroidInhalation - TYPE(DCCVector), DIMENSION(NInhalationDCCs) :: DCCInhalation - - REAL(Float) :: BreathingRate = 1.2_Float ! [m3/h] Value can be overruled later - - TYPE(NuclideType), DIMENSION(0:MaxNuclides) :: RegularizedNuclideSpecs - REAL(Float), DIMENSION(MaxNuclides,MaxNuclides) :: RegularizedMotherDaughterMatrix - -CONTAINS - - SUBROUTINE InitLibDCC(UseICRP) + & 'Exponential sources/100.0 g.cm-2/ '] + + integer, parameter :: NInhalationDCCs = 8 + + integer, parameter :: Inhalation_worker_1um = 1 + integer, parameter :: Inhalation_worker_5um = 2 + integer, parameter :: Inhalation_public_infant = 3 + integer, parameter :: Inhalation_public_1_year = 4 + integer, parameter :: Inhalation_public_5_year = 5 + integer, parameter :: Inhalation_public_10_year = 6 + integer, parameter :: Inhalation_public_15_year = 7 + integer, parameter :: Inhalation_public_adult = 8 + + type DCCVector + real(Float), dimension(MaxNuclides) :: x + end type DCCVector + + type(DCCVector), dimension(InAir:InWater,Male:Female,NTissues,NDCCAges) :: DCCTissue + type(DCCVector), dimension(NGroundDepths,NDCCAges) :: DCCGround + type(DCCVector), dimension(NGroundDepths) :: DCCEquivalentDoseGround,DCCKermaRateGround + type(DCCVector), dimension(InAir:InWater,NDCCAges) :: DCCEffectiveDose + type(DCCVector) :: DCCEquivalentDoseInAir,DCCKermaRateInAir,DCCThyroidInhalation + type(DCCVector), dimension(NInhalationDCCs) :: DCCInhalation + + type(NuclideType), dimension(0:MaxNuclides) :: RegularizedNuclideSpecs + real(Float), dimension(MaxNuclides,MaxNuclides) :: RegularizedMotherDaughterMatrix + +contains + + subroutine InitLibDCC(UseICRP) ! ! Initialize this library ! use LibUtil, only: env_var - LOGICAL, INTENT(IN) :: UseICRP + logical, intent(in) :: UseICRP character(:), allocatable :: DCCCalcPath - REAL(Float) :: tMin - INTEGER, PARAMETER :: DebugLevel = 0 + real(Float) :: tMin + integer, parameter :: DebugLevel = 0 - IF (UseICRP) THEN - CALL ReadNuclideSpecs(RIVMSourcesPath() // '/ICRP-07.NDX') - ELSE + if (UseICRP) then + call ReadNuclideSpecs(RIVMSourcesPath() // '/ICRP-07.NDX') + else ! ! Set shortest halflife that is admitted to the numerical scheme for solving the Bateman equations. ! Shorter ones are skipped: the grandmother is directly transformed into the grand-daughter. @@ -187,229 +168,227 @@ SUBROUTINE InitLibDCC(UseICRP) ! tMin = 10._Float ! [s] - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A)') 'Set shortest halflife admitted to the numerical scheme for solving the Bateman equations.' - WRITE(*,'(A)') 'Shorter ones are skipped: the grandmother is directly transformed into the grand-daughter.' - WRITE(*,'(A)') 'The missing decay steps are added afterwards.' - WRITE(*,'(A,F15.5,A)') 'For this run, we choose tMin = ',tMin,' [s]' - ENDIF + if (DebugLevel > 0) then + write(*,'(A)') 'Set shortest halflife admitted to the numerical scheme for solving the Bateman equations.' + write(*,'(A)') 'Shorter ones are skipped: the grandmother is directly transformed into the grand-daughter.' + write(*,'(A)') 'The missing decay steps are added afterwards.' + write(*,'(A,F15.5,A)') 'For this run, we choose tMin = ',tMin,' [s]' + endif - CALL ReadNProcessENDFNuclideSpecs(tMin,RegularizedNuclideSpecs,RegularizedMotherDaughterMatrix) - ENDIF + call ReadNProcessENDFNuclideSpecs(tMin,RegularizedNuclideSpecs,RegularizedMotherDaughterMatrix) + endif call env_var('COCKTAIL_DCC_ICRP_SJ_DIR', DCCCalcPath) if (.not. allocated(DCCCalcPath)) error stop 'need to set environment variable: COCKTAIL_DCC_ICRP_SJ_DIR' - DCCAirSubmersionPath = TRIM(DCCCalcPath) // '/Air submersion/' - DCCSoilContaminationPath = TRIM(DCCCalcPath) // '/Soil contamination/' - DCCWaterImmersionPath = TRIM(DCCCalcPath) // '/Water immersion/' - DCCInhalationPath = TRIM(ProjectPath)//'resources/' - END SUBROUTINE InitLibDCC + DCCAirSubmersionPath = trim(DCCCalcPath) // '/Air submersion/' + DCCSoilContaminationPath = trim(DCCCalcPath) // '/Soil contamination/' + DCCWaterImmersionPath = trim(DCCCalcPath) // '/Water immersion/' + DCCInhalationPath = trim(ProjectPath)//'resources/' + end subroutine InitLibDCC - SUBROUTINE ReadTissueDCCs() + subroutine ReadTissueDCCs() ! ! Read tissue- and gender specific DCCs ! Attention: This file has only the ICRP nuclides, but the reference in this model may be ENDF, ! which has ~ 3 x more nuclides! ! - CHARACTER(DefaultLength) :: FName,ALine - INTEGER :: iGender,iLine,jNuclide,iTissue,iAge,iImmersion,NDashLinesFound - CHARACTER(10) :: MyTissueName,MyNuclideName - LOGICAL :: IsDashLine - - DO iImmersion = InAir,InWater - DO iGender = Male,Female - FName = 'Nuclide-specific_EquivalentDose_'//TRIM(GenderName(iGender))//'.txt' - IF (iImmersion.EQ.InAir) THEN - FName = 'Air_'//TRIM(FName) - FName = TRIM(DCCAirSubmersionPath)//TRIM(FName) - ELSE - FName = 'Water_'//TRIM(FName) - FName = TRIM(DCCWaterImmersionPath)//TRIM(FName) - ENDIF - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + character(DefaultLength) :: FName,ALine + integer :: iGender,iLine,jNuclide,iTissue,iAge,iImmersion,NDashLinesFound + character(10) :: MyTissueName,MyNuclideName + logical :: IsDashLine + + do iImmersion = InAir,InWater + do iGender = Male,Female + FName = 'Nuclide-specific_EquivalentDose_'//trim(GenderName(iGender))//'.txt' + if (iImmersion == InAir) then + FName = 'Air_'//trim(FName) + FName = trim(DCCAirSubmersionPath)//trim(FName) + else + FName = 'Water_'//trim(FName) + FName = trim(DCCWaterImmersionPath)//trim(FName) + endif + open(ScratchFile,file=FName,form='FORMATTED',action='READ') ! ! Skip header ! NDashLinesFound = 0 iLine = 0 - DO WHILE (NDashLinesFound.LT.2) - READ(ScratchFile,'(A)') ALine + do while (NDashLinesFound < 2) + read(ScratchFile,'(A)') ALine iLine = iLine + 1 - IF (ALine(1:1).EQ.'-') NDashLinesFound = NDashLinesFound + 1 - ENDDO + if (ALine(1:1) == '-') NDashLinesFound = NDashLinesFound + 1 + enddo ! ! Read data for all nuclides ! IsDashLine = .FALSE. - DO WHILE (.NOT.IsDashLine) - DO iTissue = 1,NTissues - READ(ScratchFile,'(A)',END=10) ALine + do while (.NOT.IsDashLine) + do iTissue = 1,NTissues + read(ScratchFile,'(A)',end=10) ALine iLine = iLine + 1 - IsDashLine = (INDEX(ALine,'-----').GT.0) + IsDashLine = (INDEX(ALine,'-----') > 0) - IF (.NOT.IsDashLine) THEN + if (.NOT.IsDashLine) then ! ! Get nuclide and check name ! - IF (iTissue.EQ.1) THEN + if (iTissue == 1) then MyNuclideName = ALine(1:7) jNuclide = GetNuclideNumber(MyNuclideName) - IF (jNuclide.EQ.0) THEN - WRITE(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//TRIM(FName),& + if (jNuclide == 0) then + write(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//trim(FName),& & ' : found nuclide '//MyNuclideName//', but I cannot give it a number... Exiting!!' - CALL EXIT() - ENDIF - ENDIF ! First organ + call exit() + endif + endif ! First organ ! ! Get and check tissue name ! MyTissueName = ALine(9:18) - IF (MyTissueName.NE.TissueName(iTissue)) THEN - WRITE(*,'(A,I0,A)') 'At line ',iLine,& + if (MyTissueName /= TissueName(iTissue)) then + write(*,'(A,I0,A)') 'At line ',iLine,& & ' : expected tissue '//TissueName(iTissue)//', but found '//MyTissueName//'! Exiting!!' - CALL EXIT() - ENDIF + call exit() + endif ! ! Read values ! - READ(ALine(25:DefaultLength),*) (DCCTissue(iImmersion,iGender,iTissue,iAge)%x(jNuclide),iAge=1,NDCCAges) - ENDIF ! this is not a dashline - ENDDO ! loop over tissues - READ(ScratchFile,*) ! Skip line with dashes + read(ALine(25:DefaultLength),*) (DCCTissue(iImmersion,iGender,iTissue,iAge)%x(jNuclide),iAge=1,NDCCAges) + endif ! this is not a dashline + enddo ! loop over tissues + read(ScratchFile,*) ! Skip line with dashes iLine = iLine + 1 - ENDDO ! loop over nuclides + enddo ! loop over nuclides - 10 CONTINUE + 10 continue - CLOSE(ScratchFile) - ENDDO ! loop over gender - ENDDO ! loop over in air and in water - END SUBROUTINE ReadTissueDCCs + close(ScratchFile) + enddo ! loop over gender + enddo ! loop over in air and in water + end subroutine ReadTissueDCCs - SUBROUTINE ReadDCCEffectiveDose() + subroutine ReadDCCEffectiveDose() ! ! Read effective dose DCCs ! Attention: This file has only the ICRP nuclides, but the reference in this model may be ENDF, ! which has ~ 3 x more nuclides! ! - CHARACTER(DefaultLength) :: FName,ALine - INTEGER :: iLine,jNuclide,iAge,NDashLinesFound,iImmersion - CHARACTER(10) :: MyNuclideName - LOGICAL :: IsDashLine - - INTEGER, PARAMETER :: DebugLevel = 0 + character(DefaultLength) :: FName,ALine + integer :: iLine,jNuclide,iAge,NDashLinesFound,iImmersion + character(10) :: MyNuclideName + logical :: IsDashLine - DO iImmersion = InAir,InWater + do iImmersion = InAir,InWater FName = 'Nuclide-specific_EffectiveDose.txt' - IF (iImmersion.EQ.InAir) THEN - FName = 'Air_'//TRIM(FName) - FName = TRIM(DCCAirSubmersionPath)//TRIM(FName) - ELSE - FName = 'Water_'//TRIM(FName) - FName = TRIM(DCCWaterImmersionPath)//TRIM(FName) - ENDIF - - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + if (iImmersion == InAir) then + FName = 'Air_'//trim(FName) + FName = trim(DCCAirSubmersionPath)//trim(FName) + else + FName = 'Water_'//trim(FName) + FName = trim(DCCWaterImmersionPath)//trim(FName) + endif + + open(ScratchFile,file=FName,form='FORMATTED',action='READ') ! ! Skip header ! NDashLinesFound = 0 iLine = 0 - DO WHILE (NDashLinesFound.LT.2) - READ(ScratchFile,'(A)') ALine + do while (NDashLinesFound < 2) + read(ScratchFile,'(A)') ALine iLine = iLine + 1 - IF (ALine(1:1).EQ.'-') NDashLinesFound = NDashLinesFound + 1 - ENDDO + if (ALine(1:1) == '-') NDashLinesFound = NDashLinesFound + 1 + enddo ! ! Read data for all nuclides ! - DO - READ(ScratchFile,'(A)',END=10) ALine + do + read(ScratchFile,'(A)',end=10) ALine iLine = iLine + 1 - IsDashLine = (INDEX(ALine,'-----').GT.0) + IsDashLine = (INDEX(ALine,'-----') > 0) - IF (.NOT.IsDashLine) THEN + if (.NOT.IsDashLine) then ! ! Get nuclide and check name ! MyNuclideName = ALine(1:7) jNuclide = GetNuclideNumber(MyNuclideName) - IF (jNuclide.EQ.0) THEN - WRITE(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//TRIM(FName),& + if (jNuclide == 0) then + write(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//trim(FName),& & ' : found nuclide '//MyNuclideName//', but I cannot give it a number... Exiting!!' - CALL EXIT() - ENDIF + call exit() + endif ! ! Read values ! - IF (iImmersion.EQ.InAir) THEN - READ(ALine(18:DefaultLength),*) (DCCEffectiveDose(iImmersion,iAge)%x(jNuclide),iAge=1,NDCCAges),& + if (iImmersion == InAir) then + read(ALine(18:DefaultLength),*) (DCCEffectiveDose(iImmersion,iAge)%x(jNuclide),iAge=1,NDCCAges),& & DCCEquivalentDoseInAir%x(jNuclide),DCCKermaRateInAir%x(jNuclide) - ELSE - READ(ALine(18:DefaultLength),*) (DCCEffectiveDose(iImmersion,iAge)%x(jNuclide),iAge=1,NDCCAges) - ENDIF - ENDIF ! not a dash line - ENDDO ! loop over nuclides + else + read(ALine(18:DefaultLength),*) (DCCEffectiveDose(iImmersion,iAge)%x(jNuclide),iAge=1,NDCCAges) + endif + endif ! not a dash line + enddo ! loop over nuclides - 10 CONTINUE + 10 continue - CLOSE(ScratchFile) - ENDDO ! loop over air and water - END SUBROUTINE ReadDCCEffectiveDose + close(ScratchFile) + enddo ! loop over air and water + end subroutine ReadDCCEffectiveDose - SUBROUTINE ReadGroundDCCs() + subroutine ReadGroundDCCs() ! ! Read ground DCCs ! - CHARACTER(DefaultLength) :: FName,ALine - INTEGER :: iLine,jNuclide,iGroundDepth,iAge,DumLine, iSkip - CHARACTER(10) :: MyNuclideName - LOGICAL :: IsDashLine - - DO iGroundDepth = 1,NGroundDepths - FName = TRIM(GroundDepthName(iGroundDepth))//'Soil_Nuclide-specific_EffectiveDose.txt' - FName = TRIM(DCCSoilContaminationPath)//TRIM(FName) - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + character(DefaultLength) :: FName,ALine + integer :: iLine,jNuclide,iGroundDepth,iAge,iSkip + character(10) :: MyNuclideName + logical :: IsDashLine + + do iGroundDepth = 1,NGroundDepths + FName = trim(GroundDepthName(iGroundDepth))//'Soil_Nuclide-specific_EffectiveDose.txt' + FName = trim(DCCSoilContaminationPath)//trim(FName) + open(ScratchFile,file=FName,form='FORMATTED',action='READ') ! ! Skip header 10 lines ! do iSkip = 1,10 - READ(ScratchFile,*) + read(ScratchFile,*) enddo iLine = 10 ! ! Read data for all nuclides ! - DO - READ(ScratchFile,'(A)',END=10) ALine + do + read(ScratchFile,'(A)',end=10) ALine iLine = iLine + 1 - IsDashLine = (INDEX(ALine,'-----').GT.0) + IsDashLine = (INDEX(ALine,'-----') > 0) - IF (.NOT.IsDashLine) THEN + if (.NOT.IsDashLine) then ! ! Get nuclide and check name ! MyNuclideName = ALine(1:7) jNuclide = GetNuclideNumber(MyNuclideName) - IF (jNuclide.EQ.0) THEN - WRITE(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//TRIM(FName),& + if (jNuclide == 0) then + write(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//trim(FName),& & ' : found nuclide '//MyNuclideName//', but I cannot give it a number... Exiting!!' - CALL EXIT() - ENDIF + call exit() + endif ! ! Read values ! - READ(ALine(9:DefaultLength),*) (DCCGround(iGroundDepth,iAge)%x(jNuclide),iAge=1,NDCCAges),& + read(ALine(9:DefaultLength),*) (DCCGround(iGroundDepth,iAge)%x(jNuclide),iAge=1,NDCCAges),& & DCCEquivalentDoseGround(iGroundDepth)%x(jNuclide),DCCKermaRateGround(iGroundDepth)%x(jNuclide) ! ! check if it is a noble gas and if they are supposed to have groundshine @@ -420,96 +399,96 @@ SUBROUTINE ReadGroundDCCs() DCCKermaRateGround(:)%x(jNuclide) = 0._Float endif - ENDIF ! not a dash line - ENDDO ! loop over nuclides + endif ! not a dash line + enddo ! loop over nuclides - 10 CONTINUE + 10 continue - CLOSE(ScratchFile) - ENDDO ! loop over in air and in water - END SUBROUTINE ReadGroundDCCs + close(ScratchFile) + enddo ! loop over in air and in water + end subroutine ReadGroundDCCs - SUBROUTINE ReadInhalationDCCs() + subroutine ReadInhalationDCCs() ! ! Read inhalation DCCs ! - CHARACTER(DefaultLength) :: FName,ALine - INTEGER :: iLine,iNuclide,DumLine,iInhalationDCC - CHARACTER(10) :: MyNuclideName + character(DefaultLength) :: FName,ALine + integer :: iLine,iNuclide,iInhalationDCC + character(10) :: MyNuclideName FName = 'CoVeGa_v63_voorRapport_Inhalation.prn' - FName = TRIM(DCCInhalationPath)//TRIM(FName) - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + FName = trim(DCCInhalationPath)//trim(FName) + open(ScratchFile,file=FName,form='FORMATTED',action='READ') ! ! Skip header ! - READ(ScratchFile,*) + read(ScratchFile,*) ! ! Read data for all nuclides ! - DO iLine = 2,1253 - READ(ScratchFile,'(A)') ALine + do iLine = 2,1253 + read(ScratchFile,'(A)') ALine ! ! Get nuclide and check name ! - READ(ALine,*) MyNuclideName + read(ALine,*) MyNuclideName iNuclide = GetNuclideNumber(MyNuclideName) - IF (iNuclide.EQ.0) THEN - WRITE(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//TRIM(FName),& + if (iNuclide == 0) then + write(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//trim(FName),& & ' : found nuclide '//MyNuclideName//', but I cannot give it a number... Exiting!!' - CALL EXIT() - ENDIF + call exit() + endif ! ! Read values in Sv/Bq ! - READ(ALine(58:DefaultLength),*) (DCCInhalation(iInhalationDCC)%x(iNuclide),iInhalationDCC=1,NInhalationDCCs) + read(ALine(58:DefaultLength),*) (DCCInhalation(iInhalationDCC)%x(iNuclide),iInhalationDCC=1,NInhalationDCCs) - ENDDO ! loop over lines in file + enddo ! loop over lines in file - CLOSE(ScratchFile) - END SUBROUTINE ReadInhalationDCCs + close(ScratchFile) + end subroutine ReadInhalationDCCs - SUBROUTINE ReadThyroidInhalationDCCs() + subroutine ReadThyroidInhalationDCCs() ! ! Read inhalation DCCs ! - CHARACTER(DefaultLength) :: FName,ALine - INTEGER :: iLine,iNuclide,DumLine - CHARACTER(10) :: MyNuclideName - REAL(Float) :: Dum + character(DefaultLength) :: FName,ALine + integer :: iLine,iNuclide + character(10) :: MyNuclideName + real(Float) :: Dum FName = RIVMSourcesPath() // '/dccunix.dat' - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + open(ScratchFile,file=FName,form='FORMATTED',action='READ') ! ! Skip header ! - READ(ScratchFile,*) + read(ScratchFile,*) ! ! Read data for all nuclides ! - DO iLine = 2,247 - READ(ScratchFile,'(A)') ALine + do iLine = 2,247 + read(ScratchFile,'(A)') ALine ! ! Get nuclide and check name ! - READ(ALine,*) MyNuclideName + read(ALine,*) MyNuclideName iNuclide = GetNuclideNumber(MyNuclideName) - IF (iNuclide.EQ.0) THEN - WRITE(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//TRIM(FName),& + if (iNuclide == 0) then + write(*,'(A,I0,A,A)') 'At line ',iLine,' in file '//trim(FName),& & ' : found nuclide '//MyNuclideName//', but I cannot give it a number... Skipping nuclide!!' - ELSE + else ! ! Read values in Sv/Bq ! - READ(ALine(9:DefaultLength),*) Dum,DCCThyroidInhalation%x(iNuclide) - ENDIF + read(ALine(9:DefaultLength),*) Dum,DCCThyroidInhalation%x(iNuclide) + endif - ENDDO ! loop over lines in file + enddo ! loop over lines in file - CLOSE(ScratchFile) - END SUBROUTINE ReadThyroidInhalationDCCs -END MODULE LibDCC + close(ScratchFile) + end subroutine ReadThyroidInhalationDCCs +end module LibDCC diff --git a/src/lib/libendf.f90 b/src/lib/libendf.f90 index 962802a..4ba19c2 100644 --- a/src/lib/libendf.f90 +++ b/src/lib/libendf.f90 @@ -1,4 +1,4 @@ -MODULE LibENDF +module LibENDF ! ____________________________________________________ ! ! Developed For: @@ -10,15 +10,17 @@ MODULE LibENDF ! NL - 3720 BA Bilthoven ! The Netherlands - USE libxmath - USE libutil - USE Matrix_Exponential - use LibUtil, only: env_var - IMPLICIT NONE + use Matrix_Exponential + use LibUtil, only: DefaultLength, ScratchFile, & + env_var, FileExists, & + RemoveCharacter, Capitalize, CharacterIsADigit + use LibXMath, only: Float, dp, Inc, & + SparseMatrix, SparseLogicalMatrix, Matrix2SparseMatrix, LMatrix2SparseLMatrix, SparseMatrix2Matrix, SparseLMatrix2LMatrix + implicit none - PRIVATE + private public :: RIVMSourcesPath, TransitionMatrixPath - PUBLIC :: NNuclides,NuclideSpecs,MakeMotherDaughterMatrix,& + public :: NNuclides,NuclideSpecs,MakeMotherDaughterMatrix,& & MotherDaughterMatrix,FindOrphans,RegularizeNuclides,& & NuclideType,MaxNuclides,Orphanage,NuclideFamily,& & CollectProgeny,ListTransitions,MakeEvolutionMatrix,AddOrphansBelow,& @@ -26,15 +28,15 @@ MODULE LibENDF & IsRelated,RegularizedIsRelated,ReadNProcessENDFNuclideSpecs public :: isGas - INTEGER, PARAMETER :: MaxAtoms = 118 ! largest atom number available + integer, parameter :: MaxAtoms = 118 ! largest atom number available - CHARACTER(2), DIMENSION(0:MaxAtoms) :: AtomName + character(2), dimension(0:MaxAtoms) :: AtomName ! ! Number of nuclide groups ! - INTEGER, PARAMETER :: NNuclideGroups = 11 - CHARACTER(5), DIMENSION(0:NNuclideGroups), PARAMETER :: NuclideGroupName & - & = (/'Other',& + integer, parameter :: NNuclideGroups = 11 + character(5), dimension(0:NNuclideGroups), parameter :: NuclideGroupName & + & = ['Other',& & 'Noble',& & 'I ',& & 'Cs ',& @@ -45,95 +47,95 @@ MODULE LibENDF & 'Mo ',& & 'La ',& & 'Ce ',& - & 'U '/) - - TYPE AtomType - CHARACTER(13) :: Name - CHARACTER(3) :: Symbol - INTEGER :: Period,Group,NuclideGroup - CHARACTER(24) :: ChemicalSeries - REAL(Float) :: Mass - END TYPE AtomType - - INTEGER :: NAtoms = 0 - TYPE(AtomType), DIMENSION(0:MaxAtoms) :: AtomSpecs + & 'U '] + + type AtomType + character(13) :: Name + character(3) :: Symbol + integer :: Period,Group,NuclideGroup + character(24) :: ChemicalSeries + real(Float) :: Mass + end type AtomType + + integer :: NAtoms = 0 + type(AtomType), dimension(0:MaxAtoms) :: AtomSpecs ! ! The maximum number of nuclides that we will read from the database: ! - INTEGER, PARAMETER :: MaxNuclides = 4000 + integer, parameter :: MaxNuclides = 4000 ! ! - INTEGER, PARAMETER :: MaxNDaughters = 15 ! Sufficient for "normal decay", including assignment of very fast decays to their grandmothers + integer, parameter :: MaxNDaughters = 15 ! Sufficient for "normal decay", including assignment of very fast decays to their grandmothers ! ! The true number of nuclides found: ! - INTEGER :: NNuclides - - TYPE NuclideType - CHARACTER(10) :: NuclideName - CHARACTER(10), DIMENSION(MaxNDaughters) :: DaughterName - CHARACTER(40), DIMENSION(MaxNDaughters) :: DecayName - INTEGER :: NDecayModes,AtomNumber,NHadrons,NDaughters,MetaStableMode,NuclideGroup - CHARACTER(15) :: AtomName - INTEGER, DIMENSION(MaxNDaughters) :: Daughter - REAL(Float) :: HalfTime,AtomMass - REAL(Float), DIMENSION(MaxNDaughters) :: DaughterFraction,DecayFraction - LOGICAL :: IsOrphan - END TYPE NuclideType + integer :: NNuclides + + type NuclideType + character(10) :: NuclideName + character(10), dimension(MaxNDaughters) :: DaughterName + character(40), dimension(MaxNDaughters) :: DecayName + integer :: NDecayModes,AtomNumber,NHadrons,NDaughters,MetaStableMode,NuclideGroup + character(15) :: AtomName + integer, dimension(MaxNDaughters) :: Daughter + real(Float) :: HalfTime,AtomMass + real(Float), dimension(MaxNDaughters) :: DaughterFraction,DecayFraction + logical :: IsOrphan + end type NuclideType ! ! The whole lot of information will be stored in: ! - TYPE(NuclideType), DIMENSION(0:MaxNuclides) :: NuclideSpecs + type(NuclideType), dimension(0:MaxNuclides) :: NuclideSpecs ! ! A single datafile can have so many lines ! - INTEGER, PARAMETER :: MaxNLines = 30000 + integer, parameter :: MaxNLines = 30000 - INTEGER, DIMENSION(MaxNLines) :: iRecordType - LOGICAL, DIMENSION(MaxNLines) :: IsContinuation + integer, dimension(MaxNLines) :: iRecordType + logical, dimension(MaxNLines) :: IsContinuation ! ! The following types of records can be found: ! - INTEGER, PARAMETER :: iUnknownRecord = 0 - INTEGER, PARAMETER :: iTextRecord = 1 - INTEGER, PARAMETER :: iContRecord = 2 - INTEGER, PARAMETER :: iListRecord = 3 - INTEGER, PARAMETER :: iTab1Record = 4 - INTEGER, PARAMETER :: iTab2Record = 5 - INTEGER, PARAMETER :: iIntgRecord = 6 - INTEGER, PARAMETER :: iDecayRecord = 7 - - INTEGER, PARAMETER :: NRecordTypes = 7 ! should be same as last number above - - CHARACTER(7), DIMENSION(0:NRecordTypes), PARAMETER :: RecordName = & - & (/'Unknown',&! 0 + integer, parameter :: iUnknownRecord = 0 + integer, parameter :: iTextRecord = 1 + integer, parameter :: iContRecord = 2 + integer, parameter :: iListRecord = 3 + integer, parameter :: iTab1Record = 4 + integer, parameter :: iTab2Record = 5 + integer, parameter :: iIntgRecord = 6 + integer, parameter :: iDecayRecord = 7 + + integer, parameter :: NRecordTypes = 7 ! should be same as last number above + + character(7), dimension(0:NRecordTypes), parameter :: RecordName = & + & ['Unknown',&! 0 & 'Text ',&! 1 & 'Cont ',&! 2 & 'List ',&! 3 & 'Tab1 ',&! 4 & 'Tab2 ',&! 5 & 'Intg ',&! 6 - & 'Decay '/)! 7 + & 'Decay ']! 7 - CHARACTER(1), DIMENSION(0:4), PARAMETER :: MetastabilityName = & - & (/' ',&! 0 + character(1), dimension(0:4), parameter :: MetastabilityName = & + & [' ',&! 0 & 'm',&! 1 & 'n',&! 2 & 'o',&! 3 - & 'p'/)! 4 - - INTEGER, PARAMETER :: iDecayModeGamma = 0 - INTEGER, PARAMETER :: iDecayModeBeta = 1 - INTEGER, PARAMETER :: iDecayModeElectronCapture = 2 - INTEGER, PARAMETER :: iDecayModeIsomericTransition = 3 - INTEGER, PARAMETER :: iDecayModeAlpha = 4 - INTEGER, PARAMETER :: iDecayModeNeutron = 5 - INTEGER, PARAMETER :: iDecayModeSpontaneousFission = 6 - INTEGER, PARAMETER :: iDecayModeProton = 7 - INTEGER, PARAMETER :: iDecayModeUnknown = 10 - - CHARACTER(19), DIMENSION(0:10), PARAMETER :: DecayModeName = & - & (/'Gamma ',&! 0 + & 'p']! 4 + + integer, parameter :: iDecayModeGamma = 0 + integer, parameter :: iDecayModeBeta = 1 + integer, parameter :: iDecayModeElectronCapture = 2 + integer, parameter :: iDecayModeIsomericTransition = 3 + integer, parameter :: iDecayModeAlpha = 4 + integer, parameter :: iDecayModeNeutron = 5 + integer, parameter :: iDecayModeSpontaneousFission = 6 + integer, parameter :: iDecayModeProton = 7 + integer, parameter :: iDecayModeUnknown = 10 + + character(19), dimension(0:10), parameter :: DecayModeName = & + & ['Gamma ',&! 0 & 'Beta ',&! 1 & 'Electron capture ',&! 2 & 'Isomeric transition',&! 3 @@ -143,10 +145,10 @@ MODULE LibENDF & 'Proton ',&! 7 & '-invalid1- ',&! 8 & '-invalid2- ',&! 9 - & 'Unknown '/)! 10 + & 'Unknown ']! 10 - INTEGER, DIMENSION(0:10), PARAMETER :: AtomStep = & - & (/ 0,& ! Gamma + integer, dimension(0:10), parameter :: AtomStep = & + & [ 0,& ! Gamma & 1,& ! Beta & -1,& ! Electron capture & 0,& ! Isomeric transition @@ -156,10 +158,10 @@ MODULE LibENDF & -1,& ! Proton & 1000,& ! -invalid1- & 1000,& ! -invalid2- - & 1000/) ! Unknown + & 1000] ! Unknown - INTEGER, DIMENSION(0:10), PARAMETER :: MassStep = & - & (/ 0,& ! Gamma + integer, dimension(0:10), parameter :: MassStep = & + & [ 0,& ! Gamma & 0,& ! Beta & 0,& ! Electron capture & 0,& ! Isomeric transition @@ -169,47 +171,47 @@ MODULE LibENDF & -1,& ! Proton & 1000,& ! -invalid1- & 1000,& ! -invalid2- - & 1000/) ! Unknown + & 1000] ! Unknown - REAL(Float), DIMENSION(MaxNuclides,MaxNuclides) :: MotherDaughterMatrix,DecayMatrix + real(Float), dimension(MaxNuclides,MaxNuclides) :: MotherDaughterMatrix - TYPE OrphanType - INTEGER :: Mother,Daughter - REAL(Float) :: Yield,CompoundYield - LOGICAL :: Active - END TYPE OrphanType + type OrphanType + integer :: Mother,Daughter + real(Float) :: Yield,CompoundYield + logical :: Active + end type OrphanType - INTEGER, PARAMETER :: MaxNOrphans = 1700 + integer, parameter :: MaxNOrphans = 1700 - TYPE OrphanageType - REAL(Float) :: tMin - INTEGER :: NOrphans,NTooUnStable - LOGICAL, DIMENSION(MaxNuclides) :: IsTooUnstable - TYPE(OrphanType), DIMENSION(MaxNOrphans) :: Orphan - LOGICAL, DIMENSION(MaxNuclides) :: OrphanActive - END TYPE OrphanageType + type OrphanageType + real(Float) :: tMin + integer :: NOrphans,NTooUnStable + logical, dimension(MaxNuclides) :: IsTooUnstable + type(OrphanType), dimension(MaxNOrphans) :: Orphan + logical, dimension(MaxNuclides) :: OrphanActive + end type OrphanageType - TYPE(OrphanageType) :: Orphanage + type(OrphanageType) :: Orphanage - LOGICAL, DIMENSION(MaxNuclides,MaxNuclides) :: IsRelated,RegularizedIsRelated + logical, dimension(MaxNuclides,MaxNuclides) :: IsRelated,RegularizedIsRelated ! ! Structure for storing relatives stemming from 1 nuclide ! - TYPE NuclideFamilyType - INTEGER :: NFamily,NFarFamily + type NuclideFamilyType + integer :: NFamily,NFarFamily ! Equivalent of compound yield: if you start with any (specified) family member with activity 1, how much of the other ! nuclides do you find? Only contributions are counted that are linked to the starting nuclide via fast-decaying nuclides. - REAL(Float), DIMENSION(MaxNuclides) :: RemainingFraction - INTEGER, DIMENSION(MaxNuclides) :: FamilyMember,NDaughters,NMothers,FamilyNumber - INTEGER, DIMENSION(MaxNuclides,MaxNuclides) :: Mother,Daughter - LOGICAL, DIMENSION(MaxNuclides) :: IsFamily,IsFarFamily,IncomingArrowsChecked,OutgoingArrowsChecked,& + real(Float), dimension(MaxNuclides) :: RemainingFraction + integer, dimension(MaxNuclides) :: FamilyMember,NDaughters,NMothers,FamilyNumber + integer, dimension(MaxNuclides,MaxNuclides) :: Mother,Daughter + logical, dimension(MaxNuclides) :: IsFamily,IsFarFamily,IncomingArrowsChecked,OutgoingArrowsChecked,& & DescendentOfStartMember - LOGICAL, DIMENSION(MaxNuclides,MaxNuclides) :: IsRelated - END TYPE NuclideFamilyType + logical, dimension(MaxNuclides,MaxNuclides) :: IsRelated + end type NuclideFamilyType - TYPE(NuclideFamilyType) :: NuclideFamily + type(NuclideFamilyType) :: NuclideFamily -CONTAINS +contains function ENDFPath() character(:), allocatable :: ENDFPath @@ -231,25 +233,25 @@ function TransitionMatrixPath() if (.not. allocated(TransitionMatrixPath)) TransitionMatrixPath = '.' end function - INTEGER FUNCTION GetAtomNumber(Symbol) + integer function GetAtomNumber(Symbol) ! ! Search for the given name of an atom in the list of known atoms and ! return its number ! - CHARACTER(*), INTENT(IN) :: Symbol - INTEGER :: DumInt,iAtom,TheIndex - CHARACTER(10) :: DumSymbol + character(*), intent(in) :: Symbol + integer :: DumInt,iAtom,TheIndex + character(10) :: DumSymbol - DumSymbol = TRIM(Symbol) - CALL Capitalize(DumSymbol) + DumSymbol = trim(Symbol) + call Capitalize(DumSymbol) TheIndex = INDEX(DumSymbol,'-') - IF (TheIndex.GT.0) DumSymbol = DumSymbol(1:(TheIndex-1)) + if (TheIndex > 0) DumSymbol = DumSymbol(1:(TheIndex-1)) DumInt = 0 - DO iAtom = 1,NAtoms - IF (TRIM(DumSymbol).EQ.TRIM(AtomSpecs(iAtom)%Symbol)) DumInt = iAtom - ENDDO + do iAtom = 1,NAtoms + if (trim(DumSymbol) == trim(AtomSpecs(iAtom)%Symbol)) DumInt = iAtom + enddo GetAtomNumber = DumInt - END FUNCTION GetAtomNumber + end function GetAtomNumber @@ -273,11 +275,11 @@ function IsGas(nuclide) - SUBROUTINE InitNuclide(iNuclide) + subroutine InitNuclide(iNuclide) ! ! Set all info to 0 or anything else that shows clearly that the nulcide is stil empty ! - INTEGER, INTENT(IN) :: iNuclide + integer, intent(in) :: iNuclide NuclideSpecs(iNuclide)%NuclideName = ' ' NuclideSpecs(iNuclide)%DaughterName = ' ' @@ -287,465 +289,465 @@ SUBROUTINE InitNuclide(iNuclide) NuclideSpecs(iNuclide)%Daughter = 0 NuclideSpecs(iNuclide)%HalfTime = 0._Float NuclideSpecs(iNuclide)%DaughterFraction = 0._Float - END SUBROUTINE InitNuclide + end subroutine InitNuclide - SUBROUTINE ReadICRPNuclides(InName) + subroutine ReadICRPNuclides(InName) ! ! Read the names, decaytimes and daughters for a collection of nuclides ! - CHARACTER(*), INTENT(IN) :: InName + character(*), intent(in) :: InName - INTEGER :: iNuclide,jNuclide,DumInt,iDaughter,iAtom,i - CHARACTER(DefaultLength) :: ALine,DumStr - CHARACTER(2) :: Units - CHARACTER(7) :: DumStr7 - CHARACTER(7), DIMENSION(MaxNuclides) :: NuclideName - CHARACTER(11), DIMENSION(4) :: YieldStr - REAL(Float) :: C,Dum - LOGICAL, DIMENSION(MaxNuclides) :: Available - INTEGER, DIMENSION(MaxNuclides) :: SortedIndex,AtomNumber + integer :: iNuclide,jNuclide,DumInt,iDaughter,iAtom,i + character(DefaultLength) :: ALine,DumStr + character(2) :: Units + character(7) :: DumStr7 + character(7), dimension(MaxNuclides) :: NuclideName + character(11), dimension(4) :: YieldStr + real(Float) :: C,Dum + logical, dimension(MaxNuclides) :: Available + integer, dimension(MaxNuclides) :: SortedIndex,AtomNumber - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 ! ! Find number of nuclides and sort them before reading the true specs ! - OPEN(ScratchFile,FILE=TRIM(InName),FORM='FORMATTED',STATUS='OLD',& - & POSITION='REWIND') - READ(ScratchFile,*) ! Skip header + open(ScratchFile,file=trim(InName),form='FORMATTED',status='OLD',& + & position='REWIND') + read(ScratchFile,*) ! Skip header - IF(DebugLevel.GT.1) WRITE(*,*) - IF(DebugLevel.GT.1) WRITE(*,'(A)') 'First pass: the nuclides in the order as in the file:' + if(DebugLevel > 1) write(*,*) + if(DebugLevel > 1) write(*,'(A)') 'First pass: the nuclides in the order as in the file:' iNuclide = 0 - DO - READ(ScratchFile,'(A7)',END=20) DumStr7 + do + read(ScratchFile,'(A7)',end=20) DumStr7 iNuclide = iNuclide + 1 - NuclideName(iNuclide) = TRIM(DumStr7) + NuclideName(iNuclide) = trim(DumStr7) AtomNumber(iNuclide) = GetAtomNumber(NuclideName(iNuclide)) - IF(DebugLevel.GT.1) WRITE(*,'(I4,1X,A7,5X,I3,1X,A20)') iNuclide,NuclideName(iNuclide),& + if(DebugLevel > 1) write(*,'(I4,1X,A7,5X,I3,1X,A20)') iNuclide,NuclideName(iNuclide),& & AtomNumber(iNuclide),AtomSpecs(AtomNumber(iNuclide))%Name ! ! Initialize nuclide ! - CALL InitNuclide(iNuclide) + call InitNuclide(iNuclide) - ENDDO - 20 CONTINUE ! ready counting nuclides + enddo + 20 continue ! ready counting nuclides NNuclides = iNuclide ! The number of nuclides actually found in the file - IF(DebugLevel.GT.1) WRITE(*,*) + if(DebugLevel > 1) write(*,*) ! ! Sort the nuclides by atom number in stead of alphabetically ! - IF(DebugLevel.GT.1) WRITE(*,'(A)') 'Second pass: sorting the nuclides:' + if(DebugLevel > 1) write(*,'(A)') 'Second pass: sorting the nuclides:' Available = .TRUE. SortedIndex = 0 i = 0 - DO iAtom=1,NAtoms - DO iNuclide = 1,NNuclides - IF ((AtomNumber(iNuclide).EQ.iAtom).AND.(Available(iNuclide))) THEN + do iAtom=1,NAtoms + do iNuclide = 1,NNuclides + if ((AtomNumber(iNuclide) == iAtom).AND.(Available(iNuclide))) then i = i + 1 SortedIndex(iNuclide) = i Available(iNuclide) = .FALSE. - IF(DebugLevel.GT.1) WRITE(*,'(I4,1X,I3,1X,A20)') i,iAtom,TRIM(NuclideName(iNuclide)) - ENDIF - ENDDO - ENDDO - IF(DebugLevel.GT.1) WRITE(*,*) + if(DebugLevel > 1) write(*,'(I4,1X,I3,1X,A20)') i,iAtom,trim(NuclideName(iNuclide)) + endif + enddo + enddo + if(DebugLevel > 1) write(*,*) ! ! Read the specs ! - IF(DebugLevel.GT.1) WRITE(*,'(A)') 'Third pass: reading the specs:' + if(DebugLevel > 1) write(*,'(A)') 'Third pass: reading the specs:' REWIND(ScratchFile) - READ(ScratchFile,*) ! Skip header + read(ScratchFile,*) ! Skip header - DO jNuclide = 1,NNuclides + do jNuclide = 1,NNuclides iNuclide = SortedIndex(jNuclide) - READ(ScratchFile,10,END=20) ALine - 10 FORMAT(A) - IF (DebugLevel.GT.1) WRITE(*,70) jNuclide,iNuclide - 70 FORMAT('Line: ',I4,': interpreting specs for sorted nuclide ',I4) - IF (DebugLevel.GT.2) WRITE(*,60) TRIM(ALine) - 60 FORMAT('Specs from database are: "',A,'"') + read(ScratchFile,10,end=20) ALine + 10 format(A) + if (DebugLevel > 1) write(*,70) jNuclide,iNuclide + 70 format('Line: ',I4,': interpreting specs for sorted nuclide ',I4) + if (DebugLevel > 2) write(*,60) trim(ALine) + 60 format('Specs from database are: "',A,'"') ! ! Get the nuclide name ! - READ(ALine,100) NuclideSpecs(iNuclide)%NuclideName,NuclideSpecs(iNuclide)%HalfTime,Units,& + read(ALine,100) NuclideSpecs(iNuclide)%NuclideName,NuclideSpecs(iNuclide)%HalfTime,Units,& & DumStr,DumInt,DumInt,DumInt,DumInt,& & (NuclideSpecs(iNuclide)%DaughterName(iDaughter),DumStr,& & YieldStr(iDaughter),iDaughter=1,4),Dum,Dum,Dum,DumInt,DumInt,DumInt,DumInt,DumInt,& & NuclideSpecs(iNuclide)%AtomMass NuclideSpecs(iNuclide)%NHadrons = NINT(NuclideSpecs(iNuclide)%AtomMass) - 100 FORMAT(A7,F8.0,A2,A8,3I7,I6,4(1X,A7,A6,A11),f7.0,2f8.0,3i4,i5,i4,e11.0,e10.0,e9.0) + 100 format(A7,F8.0,A2,A8,3I7,I6,4(1X,A7,A6,A11),f7.0,2f8.0,3i4,i5,i4,e11.0,e10.0,e9.0) ! ! Calibrate halftime ! - IF (TRIM(Units).EQ.'y') THEN + if (trim(Units) == 'y') then C = 3600._Float*24._Float*365.25_Float - IF (DebugLevel.GT.1) WRITE(*,'(A,EN20.5)') & + if (DebugLevel > 1) write(*,'(A,EN20.5)') & & 'Half time is given in year --> conversion to seconds with factor ',C - ELSE IF (TRIM(Units).EQ.'d') THEN + else if (trim(Units) == 'd') then C = 3600._Float*24._Float - IF (DebugLevel.GT.1) WRITE(*,'(A,EN20.5)') & + if (DebugLevel > 1) write(*,'(A,EN20.5)') & & 'Half time is given in day --> conversion to seconds with factor ',C - ELSE IF (TRIM(Units).EQ.'h') THEN + else if (trim(Units) == 'h') then C = 3600._Float - IF (DebugLevel.GT.1) WRITE(*,'(A,EN20.5)') & + if (DebugLevel > 1) write(*,'(A,EN20.5)') & & 'Half time is given in hour --> conversion to seconds with factor ',C - ELSE IF (TRIM(Units).EQ.'m') THEN + else if (trim(Units) == 'm') then C = 60._Float - IF (DebugLevel.GT.1) WRITE(*,'(A,EN20.5)') & + if (DebugLevel > 1) write(*,'(A,EN20.5)') & & 'Half time is given in minute --> conversion to seconds with factor ',C - ELSE IF (TRIM(Units).EQ.'s') THEN + else if (trim(Units) == 's') then C = 1._Float - IF (DebugLevel.GT.1) WRITE(*,'(A,EN20.5)') & + if (DebugLevel > 1) write(*,'(A,EN20.5)') & & 'Half time is given in second --> conversion to seconds with factor ',C - ELSE IF (TRIM(Units).EQ.'ms') THEN + else if (trim(Units) == 'ms') then C = 1.E-3_Float - IF (DebugLevel.GT.1) WRITE(*,'(A,EN20.5)') & + if (DebugLevel > 1) write(*,'(A,EN20.5)') & & 'Half time is given in millisecond --> conversion to seconds with factor ',C - ELSE IF (TRIM(Units).EQ.'us') THEN + else if (trim(Units) == 'us') then C = 1.E-6_Float - IF (DebugLevel.GT.1) WRITE(*,'(A,EN20.5)') & + if (DebugLevel > 1) write(*,'(A,EN20.5)') & & 'Half time is given in microsecond --> conversion to seconds with factor ',C - ELSE - WRITE(*,'(A)') 'Strange unit for halftime: '//Units//' ! --> Exiting!' - CALL EXIT() - ENDIF + else + write(*,'(A)') 'Strange unit for halftime: '//Units//' ! --> Exiting!' + call exit() + endif NuclideSpecs(iNuclide)%HalfTime = NuclideSpecs(iNuclide)%HalfTime*C NuclideSpecs(iNuclide)%AtomNumber = GetAtomNumber(NuclideSpecs(iNuclide)%NuclideName) NuclideSpecs(iNuclide)%AtomName = AtomSpecs(NuclideSpecs(iNuclide)%AtomNumber)%Name - IF (DebugLevel.GT.1) THEN - IF (NuclideSpecs(iNuclide)%AtomNumber.GT.0) THEN - WRITE(*,'(A,I3,A,A)') 'Recognized atom ',NuclideSpecs(iNuclide)%AtomNumber,' : ',& - & TRIM(NuclideSpecs(iNuclide)%AtomName) - ELSE - WRITE(*,'(A)') 'This is not a nuclide related to an atom in my database...' - ENDIF - ENDIF + if (DebugLevel > 1) then + if (NuclideSpecs(iNuclide)%AtomNumber > 0) then + write(*,'(A,I3,A,A)') 'Recognized atom ',NuclideSpecs(iNuclide)%AtomNumber,' : ',& + & trim(NuclideSpecs(iNuclide)%AtomName) + else + write(*,'(A)') 'This is not a nuclide related to an atom in my database...' + endif + endif NuclideSpecs(iNuclide)%NuclideGroup = AtomSpecs(NuclideSpecs(iNuclide)%AtomNumber)%NuclideGroup ! ! Extract daughters ! - DO iDaughter=1,4 - IF (DebugLevel.GT.2) WRITE(*,'(I1,5X,A)') iDaughter,'"'//TRIM(YieldStr(iDaughter))//'"' - IF (LEN_TRIM(NuclideSpecs(iNuclide)%DaughterName(iDaughter)).GT.0) & - & READ(YieldStr(iDaughter),'(E11.0)') NuclideSpecs(iNuclide)%DaughterFraction(iDaughter) - ENDDO - - IF (DebugLevel.GT.1) THEN - WRITE(*,'(A)') 'Nuclide: '//TRIM(NuclideSpecs(iNuclide)%NuclideName) - WRITE(*,'(A,EN20.10,A)') 'Half time: ',NuclideSpecs(iNuclide)%HalfTime,' [s]' - WRITE(*,'(A,A2)') 'Units of half time: ',Units - DO iDaughter=1,4 - IF (LEN_TRIM(NuclideSpecs(iNuclide)%DaughterName(iDaughter)).GT.0) THEN - WRITE(*,'(A,I1,A,A7,A,EN20.5)') 'Daughter(',iDaughter,'): ',& - & TRIM(NuclideSpecs(iNuclide)%DaughterName(iDaughter)),& + do iDaughter=1,4 + if (DebugLevel > 2) write(*,'(I1,5X,A)') iDaughter,'"'//trim(YieldStr(iDaughter))//'"' + if (len_trim(NuclideSpecs(iNuclide)%DaughterName(iDaughter)) > 0) & + & read(YieldStr(iDaughter),'(E11.0)') NuclideSpecs(iNuclide)%DaughterFraction(iDaughter) + enddo + + if (DebugLevel > 1) then + write(*,'(A)') 'Nuclide: '//trim(NuclideSpecs(iNuclide)%NuclideName) + write(*,'(A,EN20.10,A)') 'Half time: ',NuclideSpecs(iNuclide)%HalfTime,' [s]' + write(*,'(A,A2)') 'Units of half time: ',Units + do iDaughter=1,4 + if (len_trim(NuclideSpecs(iNuclide)%DaughterName(iDaughter)) > 0) then + write(*,'(A,I1,A,A7,A,EN20.5)') 'Daughter(',iDaughter,'): ',& + & trim(NuclideSpecs(iNuclide)%DaughterName(iDaughter)),& & ' Yield: ',NuclideSpecs(iNuclide)%DaughterFraction(iDaughter) - ENDIF - ENDDO - WRITE(*,*) - ENDIF + endif + enddo + write(*,*) + endif - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A10,EN20.10)') TRIM(NuclideSpecs(iNuclide)%NuclideName),NuclideSpecs(iNuclide)%HalfTime - ENDIF + if (DebugLevel > 0) then + write(*,'(A10,EN20.10)') trim(NuclideSpecs(iNuclide)%NuclideName),NuclideSpecs(iNuclide)%HalfTime + endif - ENDDO ! loop over ICRP-file + enddo ! loop over ICRP-file - IF(DebugLevel.GT.1) WRITE(*,*) + if(DebugLevel > 1) write(*,*) - CLOSE(ScratchFile) - END SUBROUTINE ReadICRPNuclides + close(ScratchFile) + end subroutine ReadICRPNuclides - SUBROUTINE MatchDaughters + subroutine MatchDaughters ! ! Match the names of the daughters with the other nuclides. ! Exclude stable daughters ! - INTEGER :: iNuclide,iDaughter - INTEGER, PARAMETER :: DebugLevel = 0 + integer :: iNuclide,iDaughter + integer, parameter :: DebugLevel = 0 IsRelated = .FALSE. - DO iNuclide = 1,NNuclides + do iNuclide = 1,NNuclides ! ! By default the aughters is set to be irrelevant... ! - DO iDaughter = 1,MaxNDaughters + do iDaughter = 1,MaxNDaughters NuclideSpecs(iNuclide)%Daughter(iDaughter) = & & GetNuclideNumber(NuclideSpecs(iNuclide)%DaughterName(iDaughter)) - IF (NuclideSpecs(iNuclide)%Daughter(iDaughter).NE.0) THEN + if (NuclideSpecs(iNuclide)%Daughter(iDaughter) /= 0) then IsRelated(NuclideSpecs(iNuclide)%Daughter(iDaughter),iNuclide) = .TRUE. - ENDIF - ENDDO + endif + enddo ! ! Print results ! - IF (DebugLevel.GT.0) THEN - WRITE(*,40) iNuclide,& - & '"'//TRIM(NuclideSpecs(iNuclide)%NuclideName)//'"',& + if (DebugLevel > 0) then + write(*,40) iNuclide,& + & '"'//trim(NuclideSpecs(iNuclide)%NuclideName)//'"',& & NuclideSpecs(iNuclide)%AtomNumber,& - & '"'//TRIM(NuclideSpecs(iNuclide)%AtomName)//'"',& + & '"'//trim(NuclideSpecs(iNuclide)%AtomName)//'"',& & NuclideSpecs(iNuclide)%HalfTime,& - & ('"'//TRIM(NuclideSpecs(NuclideSpecs(iNuclide)%Daughter(iDaughter))%NuclideName)//'"',& + & ('"'//trim(NuclideSpecs(NuclideSpecs(iNuclide)%Daughter(iDaughter))%NuclideName)//'"',& & NuclideSpecs(iNuclide)%DaughterFraction(iDaughter),iDaughter=1,4) - 40 FORMAT(I4,'=',A12,'; atom(',I3,')=',A17,' T1/2=',G15.10,& + 40 format(I4,'=',A12,'; atom(',I3,')=',A17,' T1/2=',G15.10,& & ' --> ',4(A12,' frac=',F10.8,' ')) - WRITE(*,*) 'Ready reading nuclide!' - WRITE(*,*) '-----------------------------------------------' - WRITE(*,*) - WRITE(*,*) - ENDIF - ENDDO ! loop over nuclides - END SUBROUTINE MatchDaughters + write(*,*) 'Ready reading nuclide!' + write(*,*) '-----------------------------------------------' + write(*,*) + write(*,*) + endif + enddo ! loop over nuclides + end subroutine MatchDaughters - SUBROUTINE ReadNuclideSpecs(InName) + subroutine ReadNuclideSpecs(InName) ! ! Read the names, decaytimes and daughters for a collection of nuclides ! - CHARACTER(*), INTENT(IN) :: InName + character(*), intent(in) :: InName ! - IF (NAtoms.EQ.0) CALL ReadAtoms('atoms.dat') + if (NAtoms == 0) call ReadAtoms('atoms.dat') ! ! Read the datafile ! - IF (.NOT.FileExists(TRIM(InName))) THEN - WRITE(*,'(A)') 'Cannot find ICRP nuclide file '//'/'//TRIM(InName) - WRITE(*,'(A)') 'You can download this file via the Supplemental Material associated with '& + if (.NOT.FileExists(trim(InName))) then + write(*,'(A)') 'Cannot find ICRP nuclide file '//'/'//trim(InName) + write(*,'(A)') 'You can download this file via the Supplemental Material associated with '& & //'http://www.icrp.org/publication.asp?id=ICRP%20Publication%20107' - WRITE(*,'(A)') 'Exiting!' - CALL EXIT() - ENDIF + write(*,'(A)') 'Exiting!' + call exit() + endif - WRITE(*,'(A)') 'Going to read nuclide specs from ICRP nuclide file '//TRIM(InName) + write(*,'(A)') 'Going to read nuclide specs from ICRP nuclide file '//trim(InName) - CALL ReadICRPNuclides(InName) + call ReadICRPNuclides(InName) - WRITE(*,'(A)') 'Ready reading nuclide specs, going to match daughters...' + write(*,'(A)') 'Ready reading nuclide specs, going to match daughters...' ! ! Match the names of the daughters with the other nuclides. ! Exclude stable daughers ! - CALL MatchDaughters() - WRITE(*,'(A)') 'Ready matching daughters!' - END SUBROUTINE ReadNuclideSpecs + call MatchDaughters() + write(*,'(A)') 'Ready matching daughters!' + end subroutine ReadNuclideSpecs - SUBROUTINE MassNuc2NucMass(MyName) + subroutine MassNuc2NucMass(MyName) ! ! When applicable, convert the nuclide name from format 137mCs to Cs137m ! - CHARACTER(*), INTENT(INOUT) :: MyName - LOGICAL :: HasWrongFormat,IsMetastable,Ready - CHARACTER(10) :: MassName,NukeName - INTEGER :: iCharacter + character(*), intent(inout) :: MyName + logical :: HasWrongFormat,IsMetastable,Ready + character(10) :: MassName,NukeName + integer :: iCharacter HasWrongFormat = CharacterIsADigit(MyName(1:1)) - IF (HasWrongFormat) THEN + if (HasWrongFormat) then ! ! Get the mass number ! MassName = ' ' iCharacter = 1 Ready = .FALSE. - DO WHILE (.NOT.Ready) - MassName = TRIM(MassName)//MyName(iCharacter:iCharacter) + do while (.NOT.Ready) + MassName = trim(MassName)//MyName(iCharacter:iCharacter) iCharacter = iCharacter + 1 Ready = (.NOT.CharacterIsADigit(MyName(iCharacter:iCharacter))) - ENDDO ! not ready + enddo ! not ready ! ! Get the optional 'm' for meta-stable nuclides (case sensitive!!) ! - IsMetastable = (MyName(iCharacter:iCharacter).EQ.'m') ! This is case sensitive! Make sure you haven't converted to full uppercase yet!! + IsMetastable = (MyName(iCharacter:iCharacter) == 'm') ! This is case sensitive! Make sure you haven't converted to full uppercase yet!! - IF (IsMetastable) iCharacter = iCharacter + 1 + if (IsMetastable) iCharacter = iCharacter + 1 ! ! Get the nuclide name ! NukeName = ' ' Ready = .FALSE. - DO WHILE (.NOT.Ready) - NukeName = TRIM(NukeName)//MyName(iCharacter:iCharacter) + do while (.NOT.Ready) + NukeName = trim(NukeName)//MyName(iCharacter:iCharacter) iCharacter = iCharacter + 1 - Ready = (MyName(iCharacter:iCharacter).EQ.' ') - ENDDO ! not ready + Ready = (MyName(iCharacter:iCharacter) == ' ') + enddo ! not ready ! ! Synthesis of elements in order. E.g., Cs137m ! - IF (IsMetastable) THEN - MyName = TRIM(NukeName)//TRIM(MassName)//'m' - ELSE - MyName = TRIM(NukeName)//TRIM(MassName) - ENDIF + if (IsMetastable) then + MyName = trim(NukeName)//trim(MassName)//'m' + else + MyName = trim(NukeName)//trim(MassName) + endif - ENDIF - END SUBROUTINE MassNuc2NucMass + endif + end subroutine MassNuc2NucMass - SUBROUTINE EnsureHyphen(MyName) + subroutine EnsureHyphen(MyName) ! ! When applicable, add a hyphen as separator between atom name and mass number ! - CHARACTER(*), INTENT(INOUT) :: MyName - LOGICAL :: HasWrongFormat,IsMetastable,Ready,HasHyphen - CHARACTER(10) :: MassName,NukeName - INTEGER :: iCharacter + character(*), intent(inout) :: MyName + logical :: HasWrongFormat,Ready,HasHyphen + character(10) :: NukeName + integer :: iCharacter HasWrongFormat = CharacterIsADigit(MyName(1:1)) - IF (HasWrongFormat) CALL MassNuc2NucMass(MyName) + if (HasWrongFormat) call MassNuc2NucMass(MyName) - HasHyphen = (INDEX(MyName,'-').GT.0) + HasHyphen = (INDEX(MyName,'-') > 0) - IF (.NOT.HasHyphen) THEN + if (.NOT.HasHyphen) then ! ! Get the mass number ! NukeName = ' ' iCharacter = 1 Ready = .FALSE. - DO WHILE (.NOT.Ready) - NukeName = TRIM(NukeName)//MyName(iCharacter:iCharacter) + do while (.NOT.Ready) + NukeName = trim(NukeName)//MyName(iCharacter:iCharacter) iCharacter = iCharacter + 1 Ready = CharacterIsADigit(MyName(iCharacter:iCharacter)) - ENDDO ! not ready + enddo ! not ready - NukeName = TRIM(NukeName)//'-'//MyName((iCharacter):LEN_TRIM(MyName)) - MyName = TRIM(NukeName) - ENDIF - END SUBROUTINE EnsureHyphen + NukeName = trim(NukeName)//'-'//MyName((iCharacter):len_trim(MyName)) + MyName = trim(NukeName) + endif + end subroutine EnsureHyphen - SUBROUTINE ReadAtoms(InName) + subroutine ReadAtoms(InName) ! ! Read the specs of all known atoms ! - CHARACTER(*), INTENT(IN) :: InName + character(*), intent(in) :: InName - INTEGER :: iAtom,DumInt,iNuclideGroup - CHARACTER(DefaultLength) :: ALine,DumStr - LOGICAL :: Ready + integer :: iAtom,DumInt,iNuclideGroup + character(DefaultLength) :: ALine,DumStr + logical :: Ready - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - WRITE(*,'(A)') 'Going to read atom specs...' - OPEN(ScratchFile,FILE=(' ./data/')//TRIM(InName),FORM='FORMATTED',STATUS='OLD',& - & POSITION='REWIND') - READ(ScratchFile,*) ! Skip header + write(*,'(A)') 'Going to read atom specs...' + open(ScratchFile,file=(' ./data/')//trim(InName),form='FORMATTED',status='OLD',& + & position='REWIND') + read(ScratchFile,*) ! Skip header Ready = .FALSE. iAtom = 0 - DO WHILE (.NOT.Ready) - READ(ScratchFile,'(A)',END=20) ALine + do while (.NOT.Ready) + read(ScratchFile,'(A)',end=20) ALine iAtom = iAtom + 1 - IF (DebugLevel.GT.1) WRITE(*,70) iAtom - 70 FORMAT('Interpreting specs for Atom ',I3) - IF (DebugLevel.GT.1) WRITE(*,60) TRIM(ALine) - 60 FORMAT('Specs from database are: "',A,'"') + if (DebugLevel > 1) write(*,70) iAtom + 70 format('Interpreting specs for Atom ',I3) + if (DebugLevel > 1) write(*,60) trim(ALine) + 60 format('Specs from database are: "',A,'"') ! ! Get the atom specs ! - READ(ALine( 1: 3),'(I3)') DumInt - READ(ALine( 7:19),'(A13)') AtomSpecs(iAtom)%Name - READ(ALine(21:23),'(A3)') AtomSpecs(iAtom)%Symbol - READ(ALine(27:27),'(I1)') AtomSpecs(iAtom)%Period - READ(ALine(34:35),'(I2)') AtomSpecs(iAtom)%Group - READ(ALine(41:64),'(A24)') AtomSpecs(iAtom)%ChemicalSeries - READ(ALine(65:76),'(F12.0)') AtomSpecs(iAtom)%Mass - DumStr = ALine(78:LEN(ALine)) + read(ALine( 1: 3),'(I3)') DumInt + read(ALine( 7:19),'(A13)') AtomSpecs(iAtom)%Name + read(ALine(21:23),'(A3)') AtomSpecs(iAtom)%Symbol + read(ALine(27:27),'(I1)') AtomSpecs(iAtom)%Period + read(ALine(34:35),'(I2)') AtomSpecs(iAtom)%Group + read(ALine(41:64),'(A24)') AtomSpecs(iAtom)%ChemicalSeries + read(ALine(65:76),'(F12.0)') AtomSpecs(iAtom)%Mass + DumStr = ALine(78:len(ALine)) AtomSpecs(iAtom)%NuclideGroup = 0 - IF (LEN_TRIM(DumStr).NE.0) THEN - DO iNuclideGroup = 0,NNuclideGroups - IF (TRIM(DumStr).EQ.TRIM(NuclideGroupName(iNuclideGroup))) & + if (len_trim(DumStr) /= 0) then + do iNuclideGroup = 0,NNuclideGroups + if (trim(DumStr) == trim(NuclideGroupName(iNuclideGroup))) & & AtomSpecs(iAtom)%NuclideGroup = iNuclideGroup - ENDDO - ENDIF + enddo + endif - IF (DumInt.NE.iAtom) THEN - WRITE(*,'(A)') 'Atom number does not match line number! Exiting!!' - CALL EXIT() - ENDIF + if (DumInt /= iAtom) then + write(*,'(A)') 'Atom number does not match line number! Exiting!!' + call exit() + endif - IF (DebugLevel.GT.0) THEN - WRITE(*,200) AtomSpecs(iAtom),NuclideGroupName(AtomSpecs(iAtom)%NuclideGroup) - 200 FORMAT('Specs: "',A13,'"',1X,'"',A3,'"',1X,I2,1X,I2,1X,I2,1X,'"',A24,'"',1X,F12.8,1X,A) - ENDIF - ENDDO - 20 CONTINUE ! ready reading data + if (DebugLevel > 0) then + write(*,200) AtomSpecs(iAtom),NuclideGroupName(AtomSpecs(iAtom)%NuclideGroup) + 200 format('Specs: "',A13,'"',1X,'"',A3,'"',1X,I2,1X,I2,1X,I2,1X,'"',A24,'"',1X,F12.8,1X,A) + endif + enddo + 20 continue ! ready reading data NAtoms = iAtom - WRITE(*,'(A,I3)') '... ready reading specs for this many atoms: ',NAtoms - END SUBROUTINE ReadAtoms + write(*,'(A,I3)') '... ready reading specs for this many atoms: ',NAtoms + end subroutine ReadAtoms - SUBROUTINE InitLibENDF() + subroutine InitLibENDF() ! ! Prepare some settings before use of this library ! - CHARACTER(DefaultLength) :: FName,ALine - LOGICAL :: IsMetaStable,ValidLine,IsException - INTEGER :: iLine,MyAtomNumber + character(DefaultLength) :: FName,ALine + logical :: ValidLine,IsException + integer :: iLine,MyAtomNumber - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - FName = TRIM(ENDFPath()) // '/decay.list' + FName = trim(ENDFPath()) // '/decay.list' - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + open(ScratchFile,file=FName,form='FORMATTED',action='READ') ! ! First, scan the file to get atom names only ! - READ(ScratchFile,*) - READ(ScratchFile,*) - READ(ScratchFile,*) + read(ScratchFile,*) + read(ScratchFile,*) + read(ScratchFile,*) - DO - READ(ScratchFile,'(A)',END=10) ALine - ValidLine = (ALine(1:1).NE.'-') - IF (ValidLine) THEN - READ(ALine(7:9),*) MyAtomNumber + do + read(ScratchFile,'(A)',end=10) ALine + ValidLine = (ALine(1:1) /= '-') + if (ValidLine) then + read(ALine(7:9),*) MyAtomNumber AtomName(MyAtomNumber) = ALine(11:12) - ENDIF ! valid line - ENDDO + endif ! valid line + enddo - 10 CONTINUE + 10 continue ! ! Now, scan again and get the nuclides ! REWIND(ScratchFile) - READ(ScratchFile,*) - READ(ScratchFile,*) - READ(ScratchFile,*) + read(ScratchFile,*) + read(ScratchFile,*) + read(ScratchFile,*) NNuclides = 0 iLine = 3 - DO - READ(ScratchFile,'(A)',END=20) ALine + do + read(ScratchFile,'(A)',end=20) ALine - ValidLine = (ALine(1:1).NE.'-') + ValidLine = (ALine(1:1) /= '-') - IF (ValidLine) THEN + if (ValidLine) then NNuclides = NNuclides + 1 iLine = iLine + 1 ! @@ -756,301 +758,300 @@ SUBROUTINE InitLibENDF() ! ! Interpret line ! - IF (DebugLevel.GT.1) THEN - WRITE(*,'(A,I4,A)') 'Line ',NNuclides,' = "'//TRIM(ALine)//'"' - ENDIF + if (DebugLevel > 1) then + write(*,'(A,I4,A)') 'Line ',NNuclides,' = "'//trim(ALine)//'"' + endif - READ(ALine(7:9),*) NuclideSpecs(NNuclides)%AtomNumber + read(ALine(7:9),*) NuclideSpecs(NNuclides)%AtomNumber NuclideSpecs(NNuclides)%AtomName = ALine(11:12) - READ(ALine(14:16),*) NuclideSpecs(NNuclides)%NHadrons + read(ALine(14:16),*) NuclideSpecs(NNuclides)%NHadrons - IF (ALine(17:17).EQ.' ') THEN + if (ALine(17:17) == ' ') then NuclideSpecs(NNuclides)%MetaStableMode = 0 - ELSE IF (ALine(17:17).EQ.'M') THEN + else if (ALine(17:17) == 'M') then NuclideSpecs(NNuclides)%MetaStableMode = 1 - ELSE IF (ALine(17:17).EQ.'N') THEN + else if (ALine(17:17) == 'N') then NuclideSpecs(NNuclides)%MetaStableMode = 2 - ELSE IF (ALine(17:17).EQ.'O') THEN + else if (ALine(17:17) == 'O') then NuclideSpecs(NNuclides)%MetaStableMode = 3 - ELSE - WRITE(*,'(A,I0,A,I0,A,I0,A)') 'Unknown metastability mode "',NuclideSpecs(NNuclides)%MetaStableMode,& + else + write(*,'(A,I0,A,I0,A,I0,A)') 'Unknown metastability mode "',NuclideSpecs(NNuclides)%MetaStableMode,& & '" on line ',iLine,' for nuclide ',NNuclides,'! Exiting!!' - CALL EXIT() - ENDIF + call exit() + endif ! ! ICRP-107 knows Pm-137m and ENDF knows Pm-137. These are probably the same nuclide. ! To allow the use of both datasets simultaneously, the ENDF nuclide is mapped on the ICRP-nuclide: ! The nuclide name gets an "m". All subsequent references in ENDF to Pm-137 are trapped and re-cast to Pm-137m. ! - IsException = ((NuclideSpecs(NNuclides)%AtomName.EQ.'Pm').AND.(NuclideSpecs(NNuclides)%NHadrons.EQ.137)) - IF (IsException) NuclideSpecs(NNuclides)%MetaStableMode = 1 + IsException = ((NuclideSpecs(NNuclides)%AtomName == 'Pm').AND.(NuclideSpecs(NNuclides)%NHadrons == 137)) + if (IsException) NuclideSpecs(NNuclides)%MetaStableMode = 1 NuclideSpecs(NNuclides)%NDaughters = 0 - WRITE(NuclideSpecs(NNuclides)%NuclideName,'(A,A,I0)') & - & TRIM(NuclideSpecs(NNuclides)%AtomName),'-',NuclideSpecs(NNuclides)%NHadrons + write(NuclideSpecs(NNuclides)%NuclideName,'(A,A,I0)') & + & trim(NuclideSpecs(NNuclides)%AtomName),'-',NuclideSpecs(NNuclides)%NHadrons - NuclideSpecs(NNuclides)%NuclideName = TRIM(NuclideSpecs(NNuclides)%NuclideName)& + NuclideSpecs(NNuclides)%NuclideName = trim(NuclideSpecs(NNuclides)%NuclideName)& & //MetastabilityName(NuclideSpecs(NNuclides)%MetaStableMode) - IF (DebugLevel.GT.0) WRITE(*,'(I4,1X,A)') NNuclides,TRIM(NuclideSpecs(NNuclides)%NuclideName) - ENDIF ! valid line - ENDDO + if (DebugLevel > 0) write(*,'(I4,1X,A)') NNuclides,trim(NuclideSpecs(NNuclides)%NuclideName) + endif ! valid line + enddo - 20 CONTINUE - CLOSE(ScratchFile) - END SUBROUTINE InitLibENDF + 20 continue + close(ScratchFile) + end subroutine InitLibENDF - INTEGER FUNCTION GetNuclideNumber(NuclideName) + integer function GetNuclideNumber(NuclideName) ! ! Search for the given name of a nuclide in the list of known nuclides and ! return its number ! - CHARACTER(*), INTENT(IN) :: NuclideName - INTEGER :: DumInt,iNuclide - CHARACTER(10) :: DumNuclideName + character(*), intent(in) :: NuclideName + integer :: DumInt,iNuclide + character(10) :: DumNuclideName DumInt = 0 - IF (LEN_TRIM(NuclideName).GT.0) THEN - DumNuclideName = TRIM(NuclideName) - CALL Capitalize(DumNuclideName) - DO iNuclide = 1,NNuclides - IF (TRIM(DumNuclideName).EQ.TRIM(NuclideSpecs(iNuclide)%NuclideName)) DumInt = iNuclide - ENDDO - ENDIF ! length of input string <> 0 + if (len_trim(NuclideName) > 0) then + DumNuclideName = trim(NuclideName) + call Capitalize(DumNuclideName) + do iNuclide = 1,NNuclides + if (trim(DumNuclideName) == trim(NuclideSpecs(iNuclide)%NuclideName)) DumInt = iNuclide + enddo + endif ! length of input string <> 0 GetNuclideNumber = DumInt - END FUNCTION GetNuclideNumber + end function GetNuclideNumber - INTEGER FUNCTION AtomNMass2Nuclide(AtomNumber,NHadrons,MetastableMode) + integer function AtomNMass2Nuclide(AtomNumber,NHadrons,MetastableMode) ! ! Find the nuclide with these properties ! - INTEGER, INTENT(IN) :: AtomNumber,NHadrons,MetastableMode - INTEGER :: DumInt,iNuclide + integer, intent(in) :: AtomNumber,NHadrons,MetastableMode + integer :: DumInt,iNuclide DumInt = 0 - DO iNuclide = 1,NNuclides - IF ( (AtomNumber .EQ.NuclideSpecs(iNuclide)%AtomNumber)& - & .AND.(NHadrons .EQ.NuclideSpecs(iNuclide)%NHadrons)& - & .AND.(MetastableMode.EQ.NuclideSpecs(iNuclide)%MetastableMode)) DumInt = iNuclide - ENDDO + do iNuclide = 1,NNuclides + if ( (AtomNumber == NuclideSpecs(iNuclide)%AtomNumber)& + & .AND.(NHadrons == NuclideSpecs(iNuclide)%NHadrons)& + & .AND.(MetastableMode == NuclideSpecs(iNuclide)%MetastableMode)) DumInt = iNuclide + enddo AtomNMass2Nuclide = DumInt - END FUNCTION AtomNMass2Nuclide + end function AtomNMass2Nuclide - INTEGER FUNCTION Zap2Nuclide(Zap,iMetaStableMode) + integer function Zap2Nuclide(Zap,iMetaStableMode) ! ! Convert a ZAP-number to a nuclide index ! - INTEGER, INTENT(IN) :: Zap,iMetaStableMode + integer, intent(in) :: Zap,iMetaStableMode - INTEGER :: iAtom,iMass,iMother + integer :: iAtom,iMass,iMother iAtom = Zap/1000 iMass = Zap - 1000*iAtom iMother = AtomNMass2Nuclide(iAtom,iMass,iMetastableMode) Zap2Nuclide = iMother - END FUNCTION Zap2Nuclide + end function Zap2Nuclide - SUBROUTINE CheckRecordType(iNuclide,iLine,ALine) + subroutine CheckRecordType(iLine,ALine) ! ! Assess which type of record this is ! - INTEGER, INTENT(IN) :: iNuclide,iLine - CHARACTER(*), INTENT(IN) :: ALine + integer, intent(in) :: iLine + character(*), intent(in) :: ALine - INTEGER :: MatNumber,MFNumber,MTNumber + integer :: MatNumber,MFNumber,MTNumber - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 ! ! Read the information at the end of the line to see what type of record this is ! - READ(ALine(67:75),'(I4,I2,I3)') MatNumber,MFNumber,MTNumber + read(ALine(67:75),'(I4,I2,I3)') MatNumber,MFNumber,MTNumber - IF ((MFNumber.EQ.1).AND.(MTNumber.EQ.451)) THEN + if ((MFNumber == 1).AND.(MTNumber == 451)) then iRecordType(iLine) = iTextRecord - ELSE IF ((MFNumber.EQ.8).AND.(MTNumber.EQ.457)) THEN + else if ((MFNumber == 8).AND.(MTNumber == 457)) then iRecordType(iLine) = iDecayRecord - ENDIF + endif - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,I4,A29,3(1X,I4,1X,I2,1X,I3,4X,A))') 'Line ',iLine,& - & ' has a record of type '//RecordName(iRecordType(iLine)),MatNumber,MFNumber,MTNumber,'"'//TRIM(ALine)//'"' - ENDIF - END SUBROUTINE CheckRecordType + if (DebugLevel > 0) then + write(*,'(A,I4,A29,3(1X,I4,1X,I2,1X,I3,4X,A))') 'Line ',iLine,& + & ' has a record of type '//RecordName(iRecordType(iLine)),MatNumber,MFNumber,MTNumber,'"'//trim(ALine)//'"' + endif + end subroutine CheckRecordType - SUBROUTINE Line2Values(ALine,MySubString,MyFloat,MyInteger,SubStringIsInteger,DoingBullocks) + subroutine Line2Values(ALine,MySubString,MyFloat,MyInteger,SubStringIsInteger,DoingBullocks) ! ! Read 6 values from a line and check if they are real or integer ! - CHARACTER(*), INTENT(IN) :: ALine - INTEGER, DIMENSION(6), INTENT(OUT) :: MyInteger - REAL(Float), DIMENSION(6), INTENT(OUT) :: MyFloat - LOGICAL, DIMENSION(6), INTENT(OUT) :: SubStringIsInteger - LOGICAL, INTENT(OUT) :: DoingBullocks - CHARACTER(11), DIMENSION(6), INTENT(INOUT) :: MySubString + character(*), intent(in) :: ALine + integer, dimension(6), intent(out) :: MyInteger + real(Float), dimension(6), intent(out) :: MyFloat + logical, dimension(6), intent(out) :: SubStringIsInteger + logical, intent(out) :: DoingBullocks + character(11), dimension(6), intent(inout) :: MySubString - INTEGER :: iSubString,TheExponent,TheIndex - CHARACTER(DefaultLength) :: DumString - REAL(Float) :: RelativeDifference + integer :: iSubString,TheExponent,TheIndex + character(DefaultLength) :: DumString + real(Float) :: RelativeDifference - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - READ(ALine,'(6A11)') MySubString + read(ALine,'(6A11)') MySubString MyFloat = 0._Float MyInteger = 0 DoingBullocks = .FALSE. - DO iSubString = 1,6 - IF (DebugLevel.GT.2) WRITE(*,'(A,I0,A)') 'Substring ',iSubString,' = "'//MySubString(iSubString)//'"' - ENDDO - DO iSubString = 1,6 - IF (DebugLevel.GT.1) WRITE(*,'(A,I0,A)') 'Substring ',iSubString,' = "'//MySubString(iSubString)//'"' + do iSubString = 1,6 + if (DebugLevel > 2) write(*,'(A,I0,A)') 'Substring ',iSubString,' = "'//MySubString(iSubString)//'"' + enddo + do iSubString = 1,6 + if (DebugLevel > 1) write(*,'(A,I0,A)') 'Substring ',iSubString,' = "'//MySubString(iSubString)//'"' TheIndex = MAX(INDEX(MySubString(iSubString),'.'),& & INDEX(MySubString(iSubString),'+'),INDEX(MySubString(iSubString),'-')) - IF (TheIndex.GT.0) THEN + if (TheIndex > 0) then SubStringIsInteger(iSubString) = .FALSE. ! ! Values can be with or without E in the exponential notation, and there can be spaces in the string: ! - IF ((INDEX(MySubString(iSubString),'E').NE.0)& - & .OR.((INDEX(MySubString(iSubString),'+').EQ.0).AND.(INDEX(MySubString(iSubString),'-').EQ.0)))THEN - READ(MySubString(iSubString),*) MyFloat(iSubString) - ELSE - READ(MySubString(iSubString)(1:(TheIndex-1)),*) MyFloat(iSubString) + if ((INDEX(MySubString(iSubString),'E') /= 0)& + & .OR.((INDEX(MySubString(iSubString),'+') == 0).AND.(INDEX(MySubString(iSubString),'-') == 0)))then + read(MySubString(iSubString),*) MyFloat(iSubString) + else + read(MySubString(iSubString)(1:(TheIndex-1)),*) MyFloat(iSubString) DumString = MySubString(iSubString)(TheIndex:11) - CALL RemoveCharacter(DumString,' ') - READ(DumString,*) TheExponent + call RemoveCharacter(DumString,' ') + read(DumString,*) TheExponent MyFloat(iSubString) = MyFloat(iSubString) * 10._Float**TheExponent - ENDIF + endif ! ! If this is an integer in disguise, make it an integer (a real one! ;-) ) ! RelativeDifference = 0._Float - IF (ABS(MyFloat(iSubString)).GT.0._Float) RelativeDifference = & - & ABS(MyFloat(iSubString)-NINT(MyFloat(iSubString)))/ABS(MyFloat(iSubString)) + if (abs(MyFloat(iSubString)) > 0._Float) RelativeDifference = & + & abs(MyFloat(iSubString)-NINT(MyFloat(iSubString)))/abs(MyFloat(iSubString)) - IF ((MyFloat(iSubString).LE.1.E6_Float)& - & .AND.(RelativeDifference.LT.1.E-10_Float)) THEN + if ((MyFloat(iSubString) <= 1.E6_Float)& + & .AND.(RelativeDifference < 1.E-10_Float)) then SubStringIsInteger(iSubString) = .TRUE. MyInteger(iSubString) = NINT(MyFloat(iSubString)) - ENDIF - ELSE + endif + else SubStringIsInteger(iSubString) = .TRUE. DoingBullocks = .TRUE. - READ(MySubString(iSubString),*,END=20) MyInteger(iSubString) + read(MySubString(iSubString),*,end=20) MyInteger(iSubString) DoingBullocks = .FALSE. - ENDIF + endif - 20 CONTINUE + 20 continue ! ! Show substring ! - IF (DebugLevel.GT.1) THEN - IF (SubStringIsInteger(iSubString)) THEN - WRITE(*,'(A,I0,A,I0)') 'Substring ',iSubString,' is an integer: ',MyInteger(iSubString) - ELSE - WRITE(*,'(A,I0,A,F15.5)') 'Substring ',iSubString,' is a real : ',MyFloat(iSubString) - ENDIF - ENDIF ! debug - ENDDO ! loop over substrings - END SUBROUTINE Line2Values + if (DebugLevel > 1) then + if (SubStringIsInteger(iSubString)) then + write(*,'(A,I0,A,I0)') 'Substring ',iSubString,' is an integer: ',MyInteger(iSubString) + else + write(*,'(A,I0,A,F15.5)') 'Substring ',iSubString,' is a real : ',MyFloat(iSubString) + endif + endif ! debug + enddo ! loop over substrings + end subroutine Line2Values - SUBROUTINE Parse1DataLine(iLine,iNuclide,ALine,iLineInChapter,ReadyReadingFile,ThisLineHasDecay,iDecay) + subroutine Parse1DataLine(iLine,iNuclide,ALine,iLineInChapter,ReadyReadingFile,ThisLineHasDecay,iDecay) ! ! Try to find useful info about a known nuclide ! - INTEGER, INTENT(IN) :: iLine,iNuclide,iLineInChapter - CHARACTER(*), INTENT(IN) :: ALine - LOGICAL, INTENT(INOUT) :: ReadyReadingFile,ThisLineHasDecay - INTEGER, INTENT(INOUT) :: iDecay + integer, intent(in) :: iLine,iNuclide,iLineInChapter + character(*), intent(in) :: ALine + logical, intent(inout) :: ReadyReadingFile,ThisLineHasDecay + integer, intent(inout) :: iDecay - CHARACTER(DefaultLength) :: MyDecayModeLine - CHARACTER(80) :: PartOfLine - INTEGER :: TheIndex,iSubString,TheExponent,DaughterAtom,DaughterMass,MyDecayMode,MyMetastableMode,& - & MyAtomStep,MyMassStep,iParticle,iCompoundDecay,DaughterNuclide,iDaughter - LOGICAL, DIMENSION(6) :: SubStringIsInteger - INTEGER, DIMENSION(6) :: MyInteger - REAL(Float), DIMENSION(6) :: MyFloat - REAL(Float) :: MyFraction - LOGICAL :: Ready,IsValidDecay,DoingBullocks,IsException - CHARACTER(11), DIMENSION(6) :: MySubString + character(DefaultLength) :: MyDecayModeLine + integer :: DaughterAtom,DaughterMass,MyDecayMode,MyMetastableMode,MyAtomStep,MyMassStep,& + iParticle,iCompoundDecay,iDaughter + logical, dimension(6) :: SubStringIsInteger + integer, dimension(6) :: MyInteger + real(Float), dimension(6) :: MyFloat + real(Float) :: MyFraction + logical :: Ready,IsValidDecay,DoingBullocks,IsException + character(11), dimension(6) :: MySubString - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 DoingBullocks = .FALSE. ReadyReadingFile = .FALSE. ThisLineHasDecay = .FALSE. - IF (DebugLevel.GT.1) WRITE(*,'(A,I0,A)') 'Line ',iLine,' : "'//TRIM(ALine)//'"' + if (DebugLevel > 1) write(*,'(A,I0,A)') 'Line ',iLine,' : "'//trim(ALine)//'"' ! ! Only interpret decay info ! - IF (iRecordType(iLine).EQ.iDecayRecord) THEN - IF (DebugLevel.GT.1) WRITE(*,'(A,I4,A)') 'Decay information record ',iLineInChapter,' = "'//TRIM(ALine)//'"' + if (iRecordType(iLine) == iDecayRecord) then + if (DebugLevel > 1) write(*,'(A,I4,A)') 'Decay information record ',iLineInChapter,' = "'//trim(ALine)//'"' ! ! Read the 6 values and check if they are real/integer ! - CALL Line2Values(ALine,MySubstring,MyFloat,MyInteger,SubStringIsInteger,DoingBullocks) + call Line2Values(ALine,MySubstring,MyFloat,MyInteger,SubStringIsInteger,DoingBullocks) ! Check this criterion!!!!! - ReadyReadingFile = SubStringIsInteger(1).AND.(MyInteger(1).EQ.0)& - & .AND.SubStringIsInteger(2).AND.(MyInteger(2).EQ.0)& + ReadyReadingFile = SubStringIsInteger(1).AND.(MyInteger(1) == 0)& + & .AND.SubStringIsInteger(2).AND.(MyInteger(2) == 0)& & .AND.SubStringIsInteger(3)& - & .AND.SubStringIsInteger(4).AND.(MyInteger(4).EQ.0)& + & .AND.SubStringIsInteger(4).AND.(MyInteger(4) == 0)& & .AND.SubStringIsInteger(5)& & .AND.SubStringIsInteger(6)& - & .AND.((iLineInChapter.EQ.2).OR.(iLineInChapter.GE.5)) + & .AND.((iLineInChapter == 2).OR.(iLineInChapter >= 5)) ReadyReadingFile = ReadyReadingFile.OR.& - & ((iLineInChapter.GE.5).AND.(iDecay.GE.NuclideSpecs(iNuclide)%NDecayModes)) + & ((iLineInChapter >= 5).AND.(iDecay >= NuclideSpecs(iNuclide)%NDecayModes)) - IF (DoingBullocks) THEN - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,I0)') 'Encountering compliance problems in file for '& + if (DoingBullocks) then + if (DebugLevel > 0) then + write(*,'(A,I0)') 'Encountering compliance problems in file for '& & //NuclideSpecs(iNuclide)%NuclideName//' at line ',iLine - ENDIF ! debug - ELSE IF (ReadyReadingFile) THEN - IF (DebugLevel.GT.1) THEN - WRITE(*,'(A,I0)') 'Ready reading file for '& + endif ! debug + else if (ReadyReadingFile) then + if (DebugLevel > 1) then + write(*,'(A,I0)') 'Ready reading file for '& & //NuclideSpecs(iNuclide)%NuclideName//' at line ',iLine - ENDIF ! debug - ELSE - IF (iLineInChapter.EQ.2) THEN + endif ! debug + else + if (iLineInChapter == 2) then NuclideSpecs(iNuclide)%HalfTime = MyFloat(1) ! Even in cases where you have value e.g. 1.000, this goes well - IF (DebugLevel.GT.1) WRITE(*,'(A,EN15.5,A)') 'Halflife = ',NuclideSpecs(iNuclide)%HalfTime,' s' - ELSE IF (iLineInChapter.EQ.4) THEN + if (DebugLevel > 1) write(*,'(A,EN15.5,A)') 'Halflife = ',NuclideSpecs(iNuclide)%HalfTime,' s' + else if (iLineInChapter == 4) then NuclideSpecs(iNuclide)%NDecayModes = MyInteger(6) - IF (DebugLevel.GT.1) WRITE(*,'(A,I0)') 'Number of decay modes: ',NuclideSpecs(iNuclide)%NDecayModes - ELSE IF (iLineInChapter.GE.5) THEN + if (DebugLevel > 1) write(*,'(A,I0)') 'Number of decay modes: ',NuclideSpecs(iNuclide)%NDecayModes + else if (iLineInChapter >= 5) then MyMetastableMode = MyInteger(2) MyFraction = MyFloat(5) ! ! If you have a non-trivial decay fraction, update nuclide database ! - IF ((MyFraction.GT.0._Float).AND.(MyFraction.LE.1._Float)) THEN - IF (DebugLevel.GT.1) WRITE(*,'(A,EN15.5)') 'Acceptable fraction = ',MyFraction + if ((MyFraction > 0._Float).AND.(MyFraction <= 1._Float)) then + if (DebugLevel > 1) write(*,'(A,EN15.5)') 'Acceptable fraction = ',MyFraction iParticle = 1 MyAtomStep = 0 @@ -1059,154 +1060,151 @@ SUBROUTINE Parse1DataLine(iLine,iNuclide,ALine,iLineInChapter,ReadyReadingFile,T MyDecayModeLine = ' ' iCompoundDecay = NINT(1000000._Float*MyFloat(1)) - Ready = (iCompoundDecay.LT.1000000) + Ready = (iCompoundDecay < 1000000) - DO WHILE (.NOT.Ready) + do while (.NOT.Ready) MyDecayMode = iCompoundDecay/10**(7-iParticle) iCompoundDecay = iCompoundDecay - MyDecayMode*10**(7-iParticle) - Ready = (iCompoundDecay.EQ.0) + Ready = (iCompoundDecay == 0) - IF (iCompoundDecay.LT.0) THEN - WRITE(*,'(A,I0)') 'Faulty value for iCompoundDecay: ',iCompoundDecay - CALL EXIT() - ENDIF ! rubbish + if (iCompoundDecay < 0) then + write(*,'(A,I0)') 'Faulty value for iCompoundDecay: ',iCompoundDecay + call exit() + endif ! rubbish - IF (DebugLevel.GT.1) WRITE(*,'(A,A)') 'Found decay mode ',DecayModeName(MyDecayMode) + if (DebugLevel > 1) write(*,'(A,A)') 'Found decay mode ',DecayModeName(MyDecayMode) - MyDecayModeLine = TRIM(MyDecayModeLine)//' + '//DecayModeName(MyDecayMode) + MyDecayModeLine = trim(MyDecayModeLine)//' + '//DecayModeName(MyDecayMode) - IF ( (MyDecayMode.GE.0)& - & .AND.(MyDecayMode.LE.7)) THEN + if ( (MyDecayMode >= 0)& + & .AND.(MyDecayMode <= 7)) then IsValidDecay = .TRUE. MyAtomStep = MyAtomStep + AtomStep(MyDecayMode) MyMassStep = MyMassStep + MassStep(MyDecayMode) - ELSE + else IsValidDecay = .FALSE. - IF (DebugLevel.GT.1) WRITE(*,'(A,A,A)') & + if (DebugLevel > 1) write(*,'(A,A,A)') & & 'Found disqualifying decay mode ',DecayModeName(MyDecayMode),', making this decay invalid!!' - ENDIF ! valid decay mode + endif ! valid decay mode iParticle = iParticle + 1 - ENDDO ! ready checking all particles in this single decay + enddo ! ready checking all particles in this single decay MyDecayModeLine = MyDecayModeLine(4:DefaultLength) ! ! Account for the full train of released particles in this decay, e.g. NN, in 1 go ! - IF (IsValidDecay) THEN + if (IsValidDecay) then ThisLineHasDecay = .TRUE. iDecay = iDecay + 1 NuclideSpecs(iNuclide)%DecayFraction(iDecay) = MyFraction - IF (.NOT.(MyDecayMode.EQ.iDecayModeSpontaneousFission)) THEN + if (.NOT.(MyDecayMode == iDecayModeSpontaneousFission)) then NuclideSpecs(iNuclide)%NDaughters = NuclideSpecs(iNuclide)%NDaughters + 1 iDaughter = NuclideSpecs(iNuclide)%NDaughters DaughterAtom = NuclideSpecs(iNuclide)%AtomNumber + MyAtomStep DaughterMass = NuclideSpecs(iNuclide)%NHadrons + MyMassStep - WRITE(NuclideSpecs(iNuclide)%DaughterName(iDaughter),'(A,A,I0)') & - & TRIM(AtomName(DaughterAtom)),'-',DaughterMass + write(NuclideSpecs(iNuclide)%DaughterName(iDaughter),'(A,A,I0)') & + & trim(AtomName(DaughterAtom)),'-',DaughterMass ! ! Trap Pm-137 and recast it to Pm-137m, which is the only isotope in ICRP-107 with this combination. ! To allow for the simultaneous use of ENDF with ICRP-107, Pm-137 is renamed Pm-137m ! - IsException = ((DaughterAtom.EQ.61).AND.(DaughterMass.EQ.137)) - IF (IsException) MyMetastableMode = 1 + IsException = ((DaughterAtom == 61).AND.(DaughterMass == 137)) + if (IsException) MyMetastableMode = 1 NuclideSpecs(iNuclide)%DaughterName(iDaughter) = & - & TRIM(NuclideSpecs(iNuclide)%DaughterName(iDaughter))& + & trim(NuclideSpecs(iNuclide)%DaughterName(iDaughter))& & //MetaStabilityName(MyMetastableMode) NuclideSpecs(iNuclide)%Daughter(iDaughter) = & & GetNuclideNumber(NuclideSpecs(iNuclide)%DaughterName(iDaughter)) NuclideSpecs(iNuclide)%DaughterFraction(iDaughter) = MyFraction - NuclideSpecs(iNuclide)%DecayName(iDaughter) = TRIM(MyDecayModeLine) + NuclideSpecs(iNuclide)%DecayName(iDaughter) = trim(MyDecayModeLine) - IF (DebugLevel.GT.0) WRITE(*,'(A,I4,A,A7,A,EN15.5,A,A,A7,A,F20.10,A)') & + if (DebugLevel > 0) write(*,'(A,I4,A,A7,A,EN15.5,A,A,A7,A,F20.10,A)') & & 'Nuclide ',iNuclide,': ',& & NuclideSpecs(iNuclide)%NuclideName,& & ' with halflife ',NuclideSpecs(iNuclide)%HalfTime,' s',& & ' to daughter ',NuclideSpecs(iNuclide)%DaughterName(iDaughter),& & ' takes a fraction ',MyFraction,& - & ', decay: '//TRIM(NuclideSpecs(iNuclide)%DecayName(iDaughter)) + & ', decay: '//trim(NuclideSpecs(iNuclide)%DecayName(iDaughter)) - ELSE - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,I4,A,A7,A,EN15.5,A,A,F20.10,A)') & + else + if (DebugLevel > 0) then + write(*,'(A,I4,A,A7,A,EN15.5,A,A,F20.10,A)') & & 'Nuclide ',iNuclide,': ',& & NuclideSpecs(iNuclide)%NuclideName,& & ' with halflife ',NuclideSpecs(iNuclide)%HalfTime,& & ' s to many daughters ',& & ' takes a fraction ',MyFraction,& & ', decay: Spontaneous fission' - ENDIF - ENDIF ! SF or other valid decay - ENDIF ! valid decay mode - ELSE - IF (DebugLevel.GT.1) WRITE(*,'(A,EN15.5)') 'Unacceptable fraction = ',MyFraction - ENDIF ! yield > 0 - ENDIF ! line 2 or 5 and later in the decay chapter - ENDIF ! not doing bullocks... - ENDIF ! Inside chapter of decay records - END SUBROUTINE Parse1DataLine + endif + endif ! SF or other valid decay + endif ! valid decay mode + else + if (DebugLevel > 1) write(*,'(A,EN15.5)') 'Unacceptable fraction = ',MyFraction + endif ! yield > 0 + endif ! line 2 or 5 and later in the decay chapter + endif ! not doing bullocks... + endif ! Inside chapter of decay records + end subroutine Parse1DataLine - SUBROUTINE ParseENDFFile(iNuclide) + subroutine ParseENDFFile(iNuclide) ! ! Parse 1 of the 3821 ENDF datafiles ! - INTEGER, INTENT(IN) :: iNuclide + integer, intent(in) :: iNuclide - CHARACTER(DefaultLength) :: FName,ALine - CHARACTER(20) :: MyTail - LOGICAL :: Ready,IsNewChapter,FoundMeaningfulDecay,ThisLineHasDecay,IsException - INTEGER :: iLine,iLineInChapter,iDecay + character(DefaultLength) :: FName,ALine + character(20) :: MyTail + logical :: Ready,IsNewChapter,FoundMeaningfulDecay,ThisLineHasDecay,IsException + integer :: iLine,iLineInChapter,iDecay - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 ! ! Construct filename ! FName = 'dec-???_' - WRITE(FName(5:7),'(I3.3)') NuclideSpecs(iNuclide)%AtomNumber - FName = TRIM(FName)//TRIM(NuclideSpecs(iNuclide)%AtomName) + write(FName(5:7),'(I3.3)') NuclideSpecs(iNuclide)%AtomNumber + FName = trim(FName)//trim(NuclideSpecs(iNuclide)%AtomName) MyTail = '_???' - WRITE(MyTail(2:4),'(I3.3)') NuclideSpecs(iNuclide)%NHadrons + write(MyTail(2:4),'(I3.3)') NuclideSpecs(iNuclide)%NHadrons ! ! Trap Pm-137 and recast it to Pm-137m, which is the only isotope in ICRP-107 with this combination. ! To allow for the simultaneous use of ENDF with ICRP-107, Pm-137 is renamed Pm-137m ! - IsException = ((NuclideSpecs(iNuclide)%AtomNumber.EQ.61).AND.(NuclideSpecs(iNuclide)%NHadrons.EQ.137)) + IsException = ((NuclideSpecs(iNuclide)%AtomNumber == 61).AND.(NuclideSpecs(iNuclide)%NHadrons == 137)) - IF ((NuclideSpecs(iNuclide)%MetaStableMode.NE.0).AND..NOT.IsException) THEN - WRITE(MyTail(5:6),'(A1,I1)') 'm',NuclideSpecs(iNuclide)%MetaStableMode - ENDIF - FName = TRIM(FName)//TRIM(MyTail) + if ((NuclideSpecs(iNuclide)%MetaStableMode /= 0).AND..NOT.IsException) then + write(MyTail(5:6),'(A1,I1)') 'm',NuclideSpecs(iNuclide)%MetaStableMode + endif + FName = trim(FName)//trim(MyTail) - FName = TRIM(ENDFPath()) // '/' // TRIM(FName)//'.endf' + FName = trim(ENDFPath()) // '/' // trim(FName)//'.endf' - IF (IsException) WRITE(*,'(A)') 'To match ENDF with ICRP-107, instead of '& - & //TRIM(NuclideSpecs(iNuclide)%NuclideName)& - & //' I will read data from '//TRIM(FName) - ! IF (DebugLevel.GT.0) THEN - ! WRITE(*,'(A,I0,A)') 'Parsing file '//TRIM(FName)//' for nuclide ',iNuclide,'...' - ! ENDIF ! Debug - IF (.NOT.FileExists(FName)) THEN - WRITE(*,'(A,I0,A)') 'Cannot find file "'//TRIM(FName)//'" for nuclide ',& - & iNuclide,': '//TRIM(NuclideSpecs(iNuclide)%NuclideName)//'! Exiting!!' - CALL EXIT() - ENDIF + if (IsException) write(*,'(A)') 'To match ENDF with ICRP-107, instead of '& + & //trim(NuclideSpecs(iNuclide)%NuclideName)& + & //' I will read data from '//trim(FName) + if (.NOT.FileExists(FName)) then + write(*,'(A,I0,A)') 'Cannot find file "'//trim(FName)//'" for nuclide ',& + & iNuclide,': '//trim(NuclideSpecs(iNuclide)%NuclideName)//'! Exiting!!' + call exit() + endif ! ! Read contents ! - OPEN(ScratchFile,FILE=TRIM(FName),FORM='FORMATTED',ACTION='READ') + open(ScratchFile,file=trim(FName),form='FORMATTED',action='READ') Ready = .FALSE. iLine = 0 @@ -1217,83 +1215,81 @@ SUBROUTINE ParseENDFFile(iNuclide) FoundMeaningfulDecay = .FALSE. iDecay = 0 - DO WHILE (.NOT.Ready) - READ(ScratchFile,'(A)',END=10) ALine + do while (.NOT.Ready) + read(ScratchFile,'(A)',end=10) ALine iLine = iLine + 1 - ! WRITE(*,'(A,I4,A)') 'Line(',iLine,') = "'//TRIM(ALine)//'"' + ! write(*,'(A,I4,A)') 'Line(',iLine,') = "'//trim(ALine)//'"' ! ! Find the type of the record ! - CALL CheckRecordType(iNuclide,iLine,ALine) + call CheckRecordType(iLine,ALine) - IF (iLine.GT.1) THEN - IsNewChapter = (iRecordType(iLine).NE.iRecordType(iLine-1)) - ENDIF + if (iLine > 1) then + IsNewChapter = (iRecordType(iLine) /= iRecordType(iLine-1)) + endif - IF (IsNewChapter) THEN + if (IsNewChapter) then iLineInChapter = 1 - ELSE + else iLineInChapter = iLineInChapter + 1 - ENDIF + endif ! ! Interpret the record on the line ! - CALL Parse1DataLine(iLine,iNuclide,ALine,iLineInChapter,Ready,ThisLineHasDecay,iDecay) + call Parse1DataLine(iLine,iNuclide,ALine,iLineInChapter,Ready,ThisLineHasDecay,iDecay) FoundMeaningfulDecay = FoundMeaningfulDecay .OR. ThisLineHasDecay - IF (Ready.AND.(.NOT.FoundMeaningfulDecay)) THEN - IF (NuclideSpecs(iNuclide)%HalfTime.LT.1.E90_Float) THEN - WRITE(*,'(A,I4,A,A,A,EN20.10,A)') 'Nuclide ',iNuclide,': ',NuclideSpecs(iNuclide)%NuclideName,& + if (Ready.AND.(.NOT.FoundMeaningfulDecay)) then + if (NuclideSpecs(iNuclide)%HalfTime < 1.E90_Float) then + write(*,'(A,I4,A,A,A,EN20.10,A)') 'Nuclide ',iNuclide,': ',NuclideSpecs(iNuclide)%NuclideName,& & ' has halflife ',NuclideSpecs(iNuclide)%HalfTime,& & ', but I found end of file before I encountered any relevant decay info...' - ELSE - IF (DebugLevel.GT.0) WRITE(*,'(A,I4,A,A,A)') 'Nuclide ',iNuclide,': ',& + else + if (DebugLevel > 0) write(*,'(A,I4,A,A,A)') 'Nuclide ',iNuclide,': ',& & NuclideSpecs(iNuclide)%NuclideName,' is stable!' - ENDIF - ENDIF + endif + endif - ENDDO ! loop until ready + enddo ! loop until ready - 10 CONTINUE + 10 continue - CLOSE(ScratchFile) - END SUBROUTINE ParseENDFFile + close(ScratchFile) + end subroutine ParseENDFFile - SUBROUTINE ParseSpontaneousFile(FName) + subroutine ParseSpontaneousFile(FName) ! ! Parse an ENDF file with branching ratio's for spontaneous fission. ! Unknown yet is if the branching ratio's account for the yield or not... ! - CHARACTER(*), INTENT(IN) :: FName + character(*), intent(in) :: FName - LOGICAL :: Ready,IsSFLine,DoingBullocks,PrevLineIsSF,IsNonVoid,LastFissionProductFound - INTEGER :: iLine,SFLine,iMother,iDaughter,iParameter,NExpectedFissionProducts,NFissionProducts,iElement - CHARACTER(DefaultLength) :: ALine,DumString - CHARACTER(11), DIMENSION(12) :: MySubString - LOGICAL, DIMENSION(12) :: SubStringIsInteger - INTEGER, DIMENSION(12) :: MyInteger - INTEGER, DIMENSION(3) :: SFNuclide - REAL(Float), DIMENSION(12) :: MyFloat - REAL(Float) :: TotalYield - REAL(Float), DIMENSION(3) :: MyBranchingRatio + logical :: Ready,IsSFLine,DoingBullocks,PrevLineIsSF,IsNonVoid,LastFissionProductFound + integer :: iLine,SFLine,iMother,NExpectedFissionProducts,NFissionProducts,iElement + character(DefaultLength) :: ALine + character(11), dimension(12) :: MySubString + logical, dimension(12) :: SubStringIsInteger + integer, dimension(12) :: MyInteger + integer, dimension(3) :: SFNuclide + real(Float), dimension(12) :: MyFloat + real(Float) :: TotalYield + real(Float), dimension(3) :: MyBranchingRatio - INTEGER, PARAMETER :: DebugLevel = 0 + character(DefaultLength), parameter :: ENDFSpontaneousPath = './build/external/ENDFB_spontaneous/' - CHARACTER(DefaultLength), parameter :: ENDFSpontaneousPath = './build/external/ENDFB_spontaneous/' - - IF (.NOT.FileExists(TRIM(ENDFSpontaneousPath)//TRIM(FName))) THEN - WRITE(*,'(A)') 'Cannot find file "'//TRIM(FName)//'" for spontaneous fission! Exiting!!' - CALL EXIT() - ELSE - WRITE(*,'(A)') 'Parsing file "'//TRIM(FName)//'" for spontaneous fission!' - ENDIF + if (.NOT.FileExists(trim(ENDFSpontaneousPath)//trim(FName))) then + write(*,'(A)') 'Cannot find file "'//trim(FName)//'" for spontaneous fission! Exiting!!' + call exit() + else + write(*,'(A)') 'Parsing file "'//trim(FName)//'" for spontaneous fission!' + endif ! ! Read contents ! - OPEN(ScratchFile,FILE=TRIM(ENDFSpontaneousPath)//TRIM(FName),FORM='FORMATTED',ACTION='READ') + open(ScratchFile,file=trim(ENDFSpontaneousPath)//trim(FName),form='FORMATTED',action='READ') Ready = .FALSE. iLine = 0 @@ -1303,325 +1299,323 @@ SUBROUTINE ParseSpontaneousFile(FName) NFissionProducts = 0 LastFissionProductFound = .FALSE. - DO WHILE (.NOT.Ready) + do while (.NOT.Ready) - READ(ScratchFile,'(A)',END=10) ALine + read(ScratchFile,'(A)',end=10) ALine iLine = iLine + 1 - IsSFLine = (ALine(72:75).EQ.'8454') + IsSFLine = (ALine(72:75) == '8454') - IF (.NOT.IsSFLine) THEN - IF (PrevLineIsSF) THEN - WRITE(*,'(A,A10,A,F15.10)') 'Sum of branching ratios for spontaneous fission of ',& + if (.NOT.IsSFLine) then + if (PrevLineIsSF) then + write(*,'(A,A10,A,F15.10)') 'Sum of branching ratios for spontaneous fission of ',& & NuclideSpecs(iMother)%NuclideName,' is ',TotalYield - WRITE(*,'(A,A,A,I6,A,I6,A)') 'For ',NuclideSpecs(iMother)%NuclideName,' I expected ',& + write(*,'(A,A,A,I6,A,I6,A)') 'For ',NuclideSpecs(iMother)%NuclideName,' I expected ',& & NExpectedFissionProducts,' fission products, found ',& & NFissionProducts,' fission products!' - ENDIF + endif SFLine = 0 ! Reset Spontaneous Fission lines TotalYield = 0._Float PrevLineIsSF = .FALSE. NFissionProducts = 0 LastFissionProductFound = .FALSE. - ELSE + else SFLine = SFLine + 1 ! ! Read the 6 values and check if they are real/integer ! - CALL Line2Values(ALine,MySubString,MyFloat,MyInteger,SubStringIsInteger,DoingBullocks) + call Line2Values(ALine,MySubString,MyFloat,MyInteger,SubStringIsInteger,DoingBullocks) - IF (SFLine.EQ.1) THEN + if (SFLine == 1) then iMother = Zap2Nuclide(MyInteger(1),MyInteger(2)) - WRITE(*,'(A,I7,A,I4,A,A)') 'Head of chain for this list of spontaneous '& + write(*,'(A,I7,A,I4,A,A)') 'Head of chain for this list of spontaneous '& & //'fissions, starting at line ',iLine,' = nuclide ',& & iMother,': ',NuclideSpecs(iMother)%NuclideName - ELSE IF (SFLine.EQ.2) THEN + else if (SFLine == 2) then NExpectedFissionProducts = MyInteger(6) - ELSE IF (SFLine.GT.2) THEN - READ(ScratchFile,'(A)',END=10) ALine + else if (SFLine > 2) then + read(ScratchFile,'(A)',end=10) ALine iLine = iLine + 1 - ! IF (DebugLevel.GT.2) WRITE(*,'(A,I6,A)') 'Line ',iLine,' : "'//TRIM(ALine)//'"' - CALL Line2Values(ALine,MySubstring(7),MyFloat(7),MyInteger(7),SubStringIsInteger(7),DoingBullocks) + call Line2Values(ALine,MySubstring(7),MyFloat(7),MyInteger(7),SubStringIsInteger(7),DoingBullocks) ! ! Work out 3 nuclides per 2 lines: ! - DO iElement = 1,3 - IF (.NOT.LastFissionProductFound) THEN - IsNonVoid = (LEN_TRIM(MySubstring(4*iElement-3)).GT.0) - IF (IsNonVoid) THEN + do iElement = 1,3 + if (.NOT.LastFissionProductFound) then + IsNonVoid = (len_trim(MySubstring(4*iElement-3)) > 0) + if (IsNonVoid) then SFNuclide(iElement) = Zap2Nuclide(MyInteger(4*iElement-3),MyInteger(4*iElement-2)) MyBranchingRatio(iElement) = MyFloat(4*iElement-1) TotalYield = TotalYield + MyBranchingRatio(iElement) NFissionProducts = NFissionProducts + 1 - IF ((SFNuclide(iElement).GT.0).AND.(MyBranchingRatio(iElement).GT.0._Float)) THEN + if ((SFNuclide(iElement) > 0).AND.(MyBranchingRatio(iElement) > 0._Float)) then - WRITE(*,'(A,I8,A,A,A,A,A,EN20.10,1X,I3,1X,I3)') 'Line ',iLine,' SF: ',& + write(*,'(A,I8,A,A,A,A,A,EN20.10,1X,I3,1X,I3)') 'Line ',iLine,' SF: ',& & NuclideSpecs(iMother)%NuclideName,' --> ',& & NuclideSpecs(SFNuclide(iElement))%NuclideName,& & ' with branching ratio ',MyBranchingRatio(iElement),& & NuclideSpecs(SFNuclide(iElement))%AtomNumber,NuclideSpecs(SFNuclide(iElement))%NHadrons - ENDIF + endif - LastFissionProductFound = (NFissionProducts.GE.NExpectedFissionProducts) - ENDIF ! nonvoid - ENDIF ! not yet last fission product found - ENDDO ! loop over elements on 2 lines + LastFissionProductFound = (NFissionProducts >= NExpectedFissionProducts) + endif ! nonvoid + endif ! not yet last fission product found + enddo ! loop over elements on 2 lines PrevLineIsSF = .TRUE. - ENDIF ! SF line 1, 2 or later + endif ! SF line 1, 2 or later - ENDIF ! line with SF data - ENDDO ! loop until ready + endif ! line with SF data + enddo ! loop until ready - 10 CONTINUE - END SUBROUTINE ParseSpontaneousFile + 10 continue + end subroutine ParseSpontaneousFile - SUBROUTINE MakeMotherDaughterMatrix(MyNuclideSpecs,MyMotherDaughterMatrix,OutName) + subroutine MakeMotherDaughterMatrix(MyNuclideSpecs,MyMotherDaughterMatrix,OutName) ! ! Fill the sparse matrix of which the exponential gives the evolution of the ! nuclide strengths (in Bq possibly per unit of volume or surface) ! over a macroscopic timestep. The matrix is stored in a global variable, ! since it will be needed quite often. ! - TYPE(NuclideType), DIMENSION(0:MaxNuclides), INTENT(IN) :: MyNuclideSpecs - REAL(Float), DIMENSION(MaxNuclides,MaxNuclides), INTENT(OUT) :: MyMotherDaughterMatrix - CHARACTER(*), INTENT(IN) :: OutName - INTEGER :: DaughterNuclide,MotherNuclide,NNonZero,HerDaughterNuclide,iDaughter,iGrandDaughter - CHARACTER(30) :: FormatString - REAL(Float) :: Ln2 + type(NuclideType), dimension(0:MaxNuclides), intent(in) :: MyNuclideSpecs + real(Float), dimension(MaxNuclides,MaxNuclides), intent(out) :: MyMotherDaughterMatrix + character(*), intent(in) :: OutName + integer :: DaughterNuclide,MotherNuclide,NNonZero,iDaughter + character(30) :: FormatString + real(Float) :: Ln2 - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,I4)') 'MakeMyMotherDaughterMatrix: NNuclides = ',NNuclides - ENDIF + if (DebugLevel > 0) then + write(*,'(A,I4)') 'MakeMyMotherDaughterMatrix: NNuclides = ',NNuclides + endif - ln2 = LOG(2.) + ln2 = LOG(2._Float) ! ! Initialize diagonal with -1, rest at zero ! - DO MotherNuclide = 1,NNuclides - DO DaughterNuclide = 1,NNuclides - IF (DaughterNuclide.EQ.MotherNuclide) THEN + do MotherNuclide = 1,NNuclides + do DaughterNuclide = 1,NNuclides + if (DaughterNuclide == MotherNuclide) then MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide) = -ln2& & /MyNuclideSpecs(DaughterNuclide)%HalfTime - ELSE + else MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide) = 0. - ENDIF - ENDDO - ENDDO + endif + enddo + enddo ! ! Now fill the nonzero off-diagonal elements. Leave open the option that some daughters are accounted for several times. ! - DO MotherNuclide = 1,NNuclides - DO iDaughter = 1,MaxNDaughters + do MotherNuclide = 1,NNuclides + do iDaughter = 1,MaxNDaughters DaughterNuclide = MyNuclideSpecs(MotherNuclide)%Daughter(iDaughter) - IF (DaughterNuclide.NE.0) THEN + if (DaughterNuclide /= 0) then MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide) = & MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide) & & + MyNuclideSpecs(MotherNuclide)%DaughterFraction(iDaughter)*ln2& & /MyNuclideSpecs(DaughterNuclide)%HalfTime - ENDIF - ENDDO - ENDDO + endif + enddo + enddo ! ! Write to output ! - IF (DebugLevel.GT.0) WRITE(*,*) - IF (LEN_TRIM(OutName).GT.0) THEN - OPEN(ScratchFile,FILE = OutName,FORM='FORMATTED', POSITION='REWIND') - WRITE(ScratchFile,'(A)') 'Mother/daughter Matrix: horizontal nuclides decay into the vertical nuclides' - WRITE(ScratchFile,664) NNuclides - 664 FORMAT(I4,' nuclides are represented in this matrix. The matrix elements are for the decay of ACTIVITY!!') + if (DebugLevel > 0) write(*,*) + if (len_trim(OutName) > 0) then + open(ScratchFile,file = OutName,form='FORMATTED', position='REWIND') + write(ScratchFile,'(A)') 'Mother/daughter Matrix: horizontal nuclides decay into the vertical nuclides' + write(ScratchFile,664) NNuclides + 664 format(I4,' nuclides are represented in this matrix. The matrix elements are for the decay of ACTIVITY!!') FormatString = '(11X, (A10,1X))' - WRITE(FormatString(6:9),'(I4)') NNuclides - WRITE(ScratchFile,FormatString) (MyNuclideSpecs(MotherNuclide)%NuclideName,MotherNuclide = 1,NNuclides) + write(FormatString(6:9),'(I4)') NNuclides + write(ScratchFile,FormatString) (MyNuclideSpecs(MotherNuclide)%NuclideName,MotherNuclide = 1,NNuclides) FormatString = '(A10,1X, (G10.4,1X))' - WRITE(FormatString(9:12),'(I4)') NNuclides - DO DaughterNuclide = 1,NNuclides - WRITE(ScratchFile,FormatString) MyNuclideSpecs(DaughterNuclide)%NuclideName,& + write(FormatString(9:12),'(I4)') NNuclides + do DaughterNuclide = 1,NNuclides + write(ScratchFile,FormatString) MyNuclideSpecs(DaughterNuclide)%NuclideName,& & (MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide),MotherNuclide = 1,NNuclides) - ENDDO + enddo ! ! Count number of non-zero entries in decay matrix ! NNonZero = 0 - DO DaughterNuclide = 1,NNuclides - DO MotherNuclide = 1,NNuclides - IF (ABS(MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide)).GT.1.E-24) CALL Inc(NNonZero) - ENDDO - ENDDO + do DaughterNuclide = 1,NNuclides + do MotherNuclide = 1,NNuclides + if (abs(MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide)) > 1.E-24_Float) call Inc(NNonZero) + enddo + enddo ! ! Write only non-zero entries to output ! - WRITE(ScratchFile,*) - WRITE(ScratchFile,'(A)') 'Here come the non-zero entries of the mother/daughter matrix:' - WRITE(ScratchFile,668) NNuclides,NNonZero - 668 FORMAT(I10,1X,I10,' = NNuclides and NNonZero') - DO DaughterNuclide = 1,NNuclides - DO MotherNuclide = 1,NNuclides - IF (ABS(MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide)).GT.1.E-24) THEN - WRITE(ScratchFile,667) & + write(ScratchFile,*) + write(ScratchFile,'(A)') 'Here come the non-zero entries of the mother/daughter matrix:' + write(ScratchFile,668) NNuclides,NNonZero + 668 format(I10,1X,I10,' = NNuclides and NNonZero') + do DaughterNuclide = 1,NNuclides + do MotherNuclide = 1,NNuclides + if (abs(MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide)) > 1.E-24_Float) then + write(ScratchFile,667) & & DaughterNuclide,MotherNuclide,MyMotherDaughterMatrix(DaughterNuclide,MotherNuclide) - 667 FORMAT(I4,1X,I4,1X,G10.4) - ENDIF - ENDDO - ENDDO - CLOSE(ScratchFile) - ENDIF - END SUBROUTINE MakeMotherDaughterMatrix + 667 format(I4,1X,I4,1X,G10.4) + endif + enddo + enddo + close(ScratchFile) + endif + end subroutine MakeMotherDaughterMatrix - SUBROUTINE ReadENDFNuclideSpecs() + subroutine ReadENDFNuclideSpecs() ! ! Get all nuclide stuff you want to have from the ENDF database ! - INTEGER :: iNuclide + integer :: iNuclide - CALL InitLibENDF() + call InitLibENDF() - DO iNuclide = 1,NNuclides - CALL ParseENDFFile(iNuclide) - ENDDO ! loop over nuclides + do iNuclide = 1,NNuclides + call ParseENDFFile(iNuclide) + enddo ! loop over nuclides ! ! Spontaneous fission is skippped, as for none of these nuclides there are meaningful dose conversion coefficients. ! You can give it a go by uncommenting the commands below. No guarantee that it works. ! - ! CALL ParseSpontaneousFile('nt501') - ! CALL ParseSpontaneousFile('nt502') - ! CALL ParseSpontaneousFile('nt503') - ! CALL ParseSpontaneousFile('nt505') - ! CALL ParseSpontaneousFile('nt506') - ! CALL ParseSpontaneousFile('nt507') - ! CALL ParseSpontaneousFile('nt508') - ! CALL ParseSpontaneousFile('nt509') - ! CALL ParseSpontaneousFile('nt510') - ! CALL ParseSpontaneousFile('nt511') - ! CALL ParseSpontaneousFile('nt512') - ! CALL ParseSpontaneousFile('nt513') - ! CALL ParseSpontaneousFile('nt514') - ! CALL ParseSpontaneousFile('nt515') - ! CALL ParseSpontaneousFile('nt516') - ! CALL ParseSpontaneousFile('nt517') - ! CALL ParseSpontaneousFile('nt518') - ! CALL ParseSpontaneousFile('nt666a') - ! CALL ParseSpontaneousFile('nt666b') - ! CALL ParseSpontaneousFile('nt998') - ! CALL ParseSpontaneousFile('nt999') + ! call ParseSpontaneousFile('nt501') + ! call ParseSpontaneousFile('nt502') + ! call ParseSpontaneousFile('nt503') + ! call ParseSpontaneousFile('nt505') + ! call ParseSpontaneousFile('nt506') + ! call ParseSpontaneousFile('nt507') + ! call ParseSpontaneousFile('nt508') + ! call ParseSpontaneousFile('nt509') + ! call ParseSpontaneousFile('nt510') + ! call ParseSpontaneousFile('nt511') + ! call ParseSpontaneousFile('nt512') + ! call ParseSpontaneousFile('nt513') + ! call ParseSpontaneousFile('nt514') + ! call ParseSpontaneousFile('nt515') + ! call ParseSpontaneousFile('nt516') + ! call ParseSpontaneousFile('nt517') + ! call ParseSpontaneousFile('nt518') + ! call ParseSpontaneousFile('nt666a') + ! call ParseSpontaneousFile('nt666b') + ! call ParseSpontaneousFile('nt998') + ! call ParseSpontaneousFile('nt999') ! ! Match the names of the daughters with the other nuclides. ! Exclude stable daughers ! - CALL MatchDaughters() - WRITE(*,'(A)') 'Ready matching daughters!' - END SUBROUTINE ReadENDFNuclideSpecs + call MatchDaughters() + write(*,'(A)') 'Ready matching daughters!' + end subroutine ReadENDFNuclideSpecs - SUBROUTINE ReadNProcessENDFNuclideSpecs(tMin,RegularizedNuclideSpecs,RegularizedMotherDaughterMatrix) + subroutine ReadNProcessENDFNuclideSpecs(tMin,RegularizedNuclideSpecs,RegularizedMotherDaughterMatrix) ! ! Read ENDF nuclide database, find orphans and construct mother-daughter matrices ! - REAL(Float), INTENT(INOUT) :: tMin - TYPE(NuclideType), DIMENSION(0:MaxNuclides), INTENT(INOUT) :: RegularizedNuclideSpecs - REAL(Float), DIMENSION(MaxNuclides,MaxNuclides), INTENT(INOUT) :: RegularizedMotherDaughterMatrix + real(Float), intent(inout) :: tMin + type(NuclideType), dimension(0:MaxNuclides), intent(inout) :: RegularizedNuclideSpecs + real(Float), dimension(MaxNuclides,MaxNuclides), intent(inout) :: RegularizedMotherDaughterMatrix - TYPE(SparseMatrix) :: SparseMMMatrix,SparseRegularizedMMMatrix - REAL(Float) :: tMinSug - LOGICAL :: ENDFBinFileExists,IsDifferenttMin - TYPE(SparseLogicalMatrix) :: SparseIsRelated,SparseRegularizedIsRelated - INTEGER :: MostDaughters,iNuclide - CHARACTER(DefaultLength) :: FName + type(SparseMatrix) :: SparseMMMatrix,SparseRegularizedMMMatrix + real(Float) :: tMinSug + logical :: ENDFBinFileExists,IsDifferenttMin + type(SparseLogicalMatrix) :: SparseIsRelated,SparseRegularizedIsRelated + character(DefaultLength) :: FName - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - WRITE(*,'(A)') 'Reading the ENDF database of nuclides...' + write(*,'(A)') 'Reading the ENDF database of nuclides...' - IF (.NOT.FileExists(RIVMSourcesPath() // '/ICRP-07.NDX')) THEN - WRITE(*,'(A)') 'Make sure you have file ICRP-07.NDX in the directory where you call this utility! Exiting!!' - CALL EXIT() - ENDIF + if (.NOT.FileExists(RIVMSourcesPath() // '/ICRP-07.NDX')) then + write(*,'(A)') 'Make sure you have file ICRP-07.NDX in the directory where you call this utility! Exiting!!' + call exit() + endif ! ! Read all data on nuclides from an earlier run or construct them afresh ! ENDFBinFileExists = FileExists(TransitionMatrixPath() // '/ENDFBinFile.dat') - IF (ENDFBinFileExists) THEN + if (ENDFBinFileExists) then - WRITE(*,'(A)') 'I found the binary file ENDFBinFile.dat with all parsed ENDF data readily available!' - WRITE(*,'(A)') 'This is not the first time that you run this library!' - WRITE(*,'(A)') '' - WRITE(*,'(A)') 'Initialization will go smooth and fast!' - WRITE(*,'(A)') 'Going to read this preprocessed file ...' + write(*,'(A)') 'I found the binary file ENDFBinFile.dat with all parsed ENDF data readily available!' + write(*,'(A)') 'This is not the first time that you run this library!' + write(*,'(A)') '' + write(*,'(A)') 'Initialization will go smooth and fast!' + write(*,'(A)') 'Going to read this preprocessed file ...' - OPEN(ScratchFile,FILE=TransitionMatrixPath() // '/ENDFBinFile.dat',FORM='UNFORMATTED',POSITION='REWIND',ACTION='READ') + open(ScratchFile,file=TransitionMatrixPath() // '/ENDFBinFile.dat',form='UNFORMATTED',position='REWIND',action='READ') - READ(ScratchFile) AtomSpecs - READ(ScratchFile) AtomName - READ(ScratchFile) NNuclides - READ(ScratchFile) NuclideSpecs + read(ScratchFile) AtomSpecs + read(ScratchFile) AtomName + read(ScratchFile) NNuclides + read(ScratchFile) NuclideSpecs - IF (ALLOCATED(SparseMMMatrix%Element)) DEALLOCATE(SparseMMMatrix%Element) - READ(ScratchFile) SparseMMMatrix%N,SparseMMMatrix%NMax - ALLOCATE(SparseMMMatrix%Element(SparseMMMatrix%N)) - READ(ScratchFile) SparseMMMatrix%Element - CALL SparseMatrix2Matrix(SparseMMMatrix,MotherDaughterMatrix) + if (ALLOCATED(SparseMMMatrix%Element)) deallocate(SparseMMMatrix%Element) + read(ScratchFile) SparseMMMatrix%N,SparseMMMatrix%NMax + allocate(SparseMMMatrix%Element(SparseMMMatrix%N)) + read(ScratchFile) SparseMMMatrix%Element + call SparseMatrix2Matrix(SparseMMMatrix,MotherDaughterMatrix) - READ(ScratchFile) SparseIsRelated%N - ALLOCATE(SparseIsRelated%Element(SparseIsRelated%N)) - READ(ScratchFile) SparseIsRelated%Element - CALL SparseLMatrix2LMatrix(SparseIsRelated,IsRelated) + read(ScratchFile) SparseIsRelated%N + allocate(SparseIsRelated%Element(SparseIsRelated%N)) + read(ScratchFile) SparseIsRelated%Element + call SparseLMatrix2LMatrix(SparseIsRelated,IsRelated) - READ(ScratchFile) tMinSug - IsDifferenttMin = (ABS(tMinSug/tMin-1._Float).GT.0.001_Float) - IF (IsDifferenttMin) THEN - WRITE(*,'(A,EN20.10,A,EN20.10,A)') 'The value of tMin in the file of ',tMinSug,& + read(ScratchFile) tMinSug + IsDifferenttMin = (abs(tMinSug/tMin-1._Float) > 0.001_Float) + if (IsDifferenttMin) then + write(*,'(A,EN20.10,A,EN20.10,A)') 'The value of tMin in the file of ',tMinSug,& & ' seconds differs from the one in your subroutine call: ',tMin,' seconds!' - WRITE(*,'(A)') 'Going to replace your value by the one in tne file!' + write(*,'(A)') 'Going to replace your value by the one in tne file!' tMin = tMinSug - ENDIF + endif - READ(ScratchFile) Orphanage + read(ScratchFile) Orphanage - READ(ScratchFile) RegularizedNuclideSpecs + read(ScratchFile) RegularizedNuclideSpecs - IF (ALLOCATED(SparseRegularizedMMMatrix%Element)) DEALLOCATE(SparseRegularizedMMMatrix%Element) - READ(ScratchFile) SparseRegularizedMMMatrix%N,SparseRegularizedMMMatrix%NMax - ALLOCATE(SparseRegularizedMMMatrix%Element(SparseRegularizedMMMatrix%N)) - READ(ScratchFile) SparseRegularizedMMMatrix%Element - CALL SparseMatrix2Matrix(SparseRegularizedMMMatrix,RegularizedMotherDaughterMatrix) + if (ALLOCATED(SparseRegularizedMMMatrix%Element)) deallocate(SparseRegularizedMMMatrix%Element) + read(ScratchFile) SparseRegularizedMMMatrix%N,SparseRegularizedMMMatrix%NMax + allocate(SparseRegularizedMMMatrix%Element(SparseRegularizedMMMatrix%N)) + read(ScratchFile) SparseRegularizedMMMatrix%Element + call SparseMatrix2Matrix(SparseRegularizedMMMatrix,RegularizedMotherDaughterMatrix) - READ(ScratchFile) SparseRegularizedIsRelated%N - ALLOCATE(SparseRegularizedIsRelated%Element(SparseRegularizedIsRelated%N)) - READ(ScratchFile) SparseRegularizedIsRelated%Element - CALL SparseLMatrix2LMatrix(SparseRegularizedIsRelated,RegularizedIsRelated) + read(ScratchFile) SparseRegularizedIsRelated%N + allocate(SparseRegularizedIsRelated%Element(SparseRegularizedIsRelated%N)) + read(ScratchFile) SparseRegularizedIsRelated%Element + call SparseLMatrix2LMatrix(SparseRegularizedIsRelated,RegularizedIsRelated) - CLOSE(ScratchFile) + close(ScratchFile) - WRITE(*,'(A)') 'Ready reading preprocessed ENDF file ...' - ELSE - WRITE(*,'(A)') 'I could not find the binary file ENDFBinFile.dat with all parsed ENDF data readily available...' - WRITE(*,'(A)') 'This is probably the first time that you run this library...' - WRITE(*,'(A)') '' - WRITE(*,'(A)') 'Going to read all the ENDF data files one by one and parse them ...' - WRITE(*,'(A)') 'This may take some time ...' + write(*,'(A)') 'Ready reading preprocessed ENDF file ...' + else + write(*,'(A)') 'I could not find the binary file ENDFBinFile.dat with all parsed ENDF data readily available...' + write(*,'(A)') 'This is probably the first time that you run this library...' + write(*,'(A)') '' + write(*,'(A)') 'Going to read all the ENDF data files one by one and parse them ...' + write(*,'(A)') 'This may take some time ...' - CALL ReadENDFNuclideSpecs() + call ReadENDFNuclideSpecs() ! ! Find all orphan decay steps, i.e. those involving a halflife < tMin, and put them in a list ! - CALL FindOrphans(tMin) + call FindOrphans(tMin) ! ! Make a copy of the nuclide specs with which we can play ! The original is kept such that we will be able to trace the true family relations @@ -1630,87 +1624,87 @@ SUBROUTINE ReadNProcessENDFNuclideSpecs(tMin,RegularizedNuclideSpecs,Regularized ! ! Regularize nuclide specs by elimination of too fast nuclides ! - CALL RegularizeNuclides(RegularizedNuclideSpecs) + call RegularizeNuclides(RegularizedNuclideSpecs) - WRITE(*,*) + write(*,*) !================================================================================================================ ! ! Construct matrix with time-rate-of-change of nuclide vector, based on the regularized transition characteristics ! - WRITE(*,*) - WRITE(*,'(A)') 'Going to construct mother-daughter matrix for time-rate-of-change!' + write(*,*) + write(*,'(A)') 'Going to construct mother-daughter matrix for time-rate-of-change!' ! ! Once for the original full set of decay options ! FName = ' ' - CALL MakeMotherDaughterMatrix(NuclideSpecs,MotherDaughterMatrix,FName) + call MakeMotherDaughterMatrix(NuclideSpecs,MotherDaughterMatrix,FName) ! ! And once for the regularized set of decay relations, where all orphans have been taken out ! FName = ' ' - CALL MakeMotherDaughterMatrix(RegularizedNuclideSpecs,RegularizedMotherDaughterMatrix,FName) + call MakeMotherDaughterMatrix(RegularizedNuclideSpecs,RegularizedMotherDaughterMatrix,FName) - WRITE(*,'(A)') 'Ready reading and parsting all the ENDF data files!' + write(*,'(A)') 'Ready reading and parsting all the ENDF data files!' - OPEN(ScratchFile,FILE=TransitionMatrixPath() // '/ENDFBinFile.dat',FORM='UNFORMATTED',POSITION='REWIND',ACTION='WRITE') + open(ScratchFile,file=TransitionMatrixPath() // '/ENDFBinFile.dat',form='UNFORMATTED',position='REWIND',action='WRITE') - WRITE(ScratchFile) AtomSpecs - WRITE(ScratchFile) AtomName - WRITE(ScratchFile) NNuclides - WRITE(ScratchFile) NuclideSpecs + write(ScratchFile) AtomSpecs + write(ScratchFile) AtomName + write(ScratchFile) NNuclides + write(ScratchFile) NuclideSpecs SparseMMMatrix = Matrix2SparseMatrix(MotherDaughterMatrix) - WRITE(ScratchFile) SparseMMMatrix%N,SparseMMMatrix%NMax - WRITE(ScratchFile) SparseMMMatrix%Element + write(ScratchFile) SparseMMMatrix%N,SparseMMMatrix%NMax + write(ScratchFile) SparseMMMatrix%Element SparseIsRelated = LMatrix2SparseLMatrix(IsRelated) - WRITE(ScratchFile) SparseIsRelated%N - WRITE(ScratchFile) SparseIsRelated%Element - WRITE(ScratchFile) tMin - WRITE(ScratchFile) Orphanage - WRITE(ScratchFile) RegularizedNuclideSpecs + write(ScratchFile) SparseIsRelated%N + write(ScratchFile) SparseIsRelated%Element + write(ScratchFile) tMin + write(ScratchFile) Orphanage + write(ScratchFile) RegularizedNuclideSpecs SparseRegularizedMMMatrix = Matrix2SparseMatrix(RegularizedMotherDaughterMatrix) - WRITE(ScratchFile) SparseRegularizedMMMatrix%N,SparseRegularizedMMMatrix%NMax - WRITE(ScratchFile) SparseRegularizedMMMatrix%Element + write(ScratchFile) SparseRegularizedMMMatrix%N,SparseRegularizedMMMatrix%NMax + write(ScratchFile) SparseRegularizedMMMatrix%Element SparseRegularizedIsRelated = LMatrix2SparseLMatrix(RegularizedIsRelated) - WRITE(ScratchFile) SparseRegularizedIsRelated%N - WRITE(ScratchFile) SparseRegularizedIsRelated%Element + write(ScratchFile) SparseRegularizedIsRelated%N + write(ScratchFile) SparseRegularizedIsRelated%Element - CLOSE(ScratchFile) + close(ScratchFile) - WRITE(*,'(A)') 'Created binary file ENDFBinFile.dat with all parsed ENDF data for future use!' + write(*,'(A)') 'Created binary file ENDFBinFile.dat with all parsed ENDF data for future use!' - ENDIF ! Binary data already available + endif ! Binary data already available - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,I0,A)') 'AtomSpecs takes : ',SIZEOF(AtomSpecs),' bytes' - WRITE(*,'(A,I0,A)') 'AtomName takes : ',SIZEOF(AtomName),' bytes' - WRITE(*,'(A,I0,A)') 'NNuclides takes : ',SIZEOF(NNuclides),' bytes' - WRITE(*,'(A,I0,A)') 'NuclideSpecs takes : ',SIZEOF(NuclideSpecs),' bytes' - WRITE(*,'(A,I0,A)') 'SparseMMMatrix takes : ',SIZEOF(SparseMMMatrix%Element),' bytes' - WRITE(*,'(A,I0,A)') 'SparseIsRelated takes : ',SIZEOF(SparseIsRelated%Element),' bytes' - WRITE(*,'(A,I0,A)') 'tMinSug takes : ',SIZEOF(tMinSug),' bytes' - WRITE(*,'(A,I0,A)') 'Orphanage takes : ',SIZEOF(Orphanage),' bytes' - WRITE(*,'(A,I0,A)') 'RegularizedNuclideSpecs takes : ',SIZEOF(RegularizedNuclideSpecs),' bytes' - WRITE(*,'(A,I0,A)') 'SparseRegularizedMMMatrix takes : ',SIZEOF(SparseRegularizedMMMatrix%Element),' bytes' - WRITE(*,'(A,I0,A)') 'SparseRegularizedIsRelated takes : ',SIZEOF(SparseRegularizedIsRelated%Element),' bytes' - ENDIF - END SUBROUTINE ReadNProcessENDFNuclideSpecs + if (DebugLevel > 0) then + write(*,'(A,I0,A)') 'AtomSpecs takes : ',SIZEOF(AtomSpecs),' bytes' + write(*,'(A,I0,A)') 'AtomName takes : ',SIZEOF(AtomName),' bytes' + write(*,'(A,I0,A)') 'NNuclides takes : ',SIZEOF(NNuclides),' bytes' + write(*,'(A,I0,A)') 'NuclideSpecs takes : ',SIZEOF(NuclideSpecs),' bytes' + write(*,'(A,I0,A)') 'SparseMMMatrix takes : ',SIZEOF(SparseMMMatrix%Element),' bytes' + write(*,'(A,I0,A)') 'SparseIsRelated takes : ',SIZEOF(SparseIsRelated%Element),' bytes' + write(*,'(A,I0,A)') 'tMinSug takes : ',SIZEOF(tMinSug),' bytes' + write(*,'(A,I0,A)') 'Orphanage takes : ',SIZEOF(Orphanage),' bytes' + write(*,'(A,I0,A)') 'RegularizedNuclideSpecs takes : ',SIZEOF(RegularizedNuclideSpecs),' bytes' + write(*,'(A,I0,A)') 'SparseRegularizedMMMatrix takes : ',SIZEOF(SparseRegularizedMMMatrix%Element),' bytes' + write(*,'(A,I0,A)') 'SparseRegularizedIsRelated takes : ',SIZEOF(SparseRegularizedIsRelated%Element),' bytes' + endif + end subroutine ReadNProcessENDFNuclideSpecs - SUBROUTINE FindOrphans(tMin) + subroutine FindOrphans(tMin) !================================================================================================================ ! ! Find the orphans: nuclides with halftime shorter than Orphanage%tMin ! !================================================================================================================ - REAL(Float), INTENT(IN) :: tMin + real(Float), intent(in) :: tMin - INTEGER :: DaughterNuclide,MotherNuclide,NMothers,iDaughter,HerDaughterNuclide,iOrphan + integer :: DaughterNuclide,MotherNuclide,NMothers,iDaughter,HerDaughterNuclide,iOrphan - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - WRITE(*,*) - WRITE(*,'(A)') 'Starting to look for orphan nuclides!' + write(*,*) + write(*,'(A)') 'Starting to look for orphan nuclides!' Orphanage%tMin = tMin ! @@ -1719,11 +1713,11 @@ SUBROUTINE FindOrphans(tMin) Orphanage%NOrphans = 0 Orphanage%NTooUnStable = 0 - DO DaughterNuclide = 1,NNuclides - Orphanage%IsTooUnstable(DaughterNuclide) = (NuclideSpecs(DaughterNuclide)%HalfTime.LT.Orphanage%tMin) - IF (Orphanage%IsTooUnstable(DaughterNuclide)) THEN - IF (DebugLevel.GT.0) WRITE(*,'(A,EN20.10,A,EN20.10,A)') 'Handling too fast nuclide '& - & //TRIM(NuclideSpecs(DaughterNuclide)%NuclideName)//' with halflife ',NuclideSpecs(DaughterNuclide)%HalfTime,& + do DaughterNuclide = 1,NNuclides + Orphanage%IsTooUnstable(DaughterNuclide) = (NuclideSpecs(DaughterNuclide)%HalfTime < Orphanage%tMin) + if (Orphanage%IsTooUnstable(DaughterNuclide)) then + if (DebugLevel > 0) write(*,'(A,EN20.10,A,EN20.10,A)') 'Handling too fast nuclide '& + & //trim(NuclideSpecs(DaughterNuclide)%NuclideName)//' with halflife ',NuclideSpecs(DaughterNuclide)%HalfTime,& & ' [s] < ',Orphanage%tMin,'[s]' NuclideSpecs(DaughterNuclide)%IsOrphan = .TRUE. @@ -1734,55 +1728,55 @@ SUBROUTINE FindOrphans(tMin) ! NMothers = 0 - DO MotherNuclide = 1,NNuclides - DO iDaughter = 1,MaxNDaughters + do MotherNuclide = 1,NNuclides + do iDaughter = 1,MaxNDaughters HerDaughterNuclide = NuclideSpecs(MotherNuclide)%Daughter(iDaughter) ! ! If a possible mother has been found, then define a new orphan ! - IF (DaughterNuclide.EQ.HerDaughterNuclide) THEN + if (DaughterNuclide == HerDaughterNuclide) then NMothers = NMothers + 1 - IF (DebugLevel.GT.0) WRITE(*,'(A,I0,A,F15.10)') & - & 'Found mother '//TRIM(NuclideSpecs(MotherNuclide)%NuclideName)//& - & ' and '//TRIM(NuclideSpecs(DaughterNuclide)%NuclideName)//' is her daughter number ',iDaughter,& + if (DebugLevel > 0) write(*,'(A,I0,A,F15.10)') & + & 'Found mother '//trim(NuclideSpecs(MotherNuclide)%NuclideName)//& + & ' and '//trim(NuclideSpecs(DaughterNuclide)%NuclideName)//' is her daughter number ',iDaughter,& & ' with branching ratio ',NuclideSpecs(MotherNuclide)%DaughterFraction(iDaughter) - IF (Orphanage%NOrphans.EQ.MaxNOrphans) THEN - WRITE(*,'(A,I0,A)') 'Cannot add new orphan after maximum number of ',& + if (Orphanage%NOrphans == MaxNOrphans) then + write(*,'(A,I0,A)') 'Cannot add new orphan after maximum number of ',& & Orphanage%NOrphans,' orphans! Exiting!!' - CALL EXIT() - ENDIF ! maximum dimension reached + call exit() + endif ! maximum dimension reached Orphanage%NOrphans = Orphanage%NOrphans + 1 Orphanage%Orphan(Orphanage%NOrphans)%Mother = MotherNuclide Orphanage%Orphan(Orphanage%NOrphans)%Daughter = DaughterNuclide Orphanage%Orphan(Orphanage%NOrphans)%yield = NuclideSpecs(MotherNuclide)%DaughterFraction(iDaughter) - ENDIF ! Recognition of daughter by mother - ENDDO ! loop over daughters - ENDDO ! Loop over candidate mothers - - IF (DebugLevel.GT.0) THEN - IF (NMothers.GT.0) THEN - WRITE(*,'(A,I0,A)') 'Found ',NMothers,' mothers for '//TRIM(NuclideSpecs(DaughterNuclide)%NuclideName)//'!' - ELSE - WRITE(*,'(A)') 'No mothers were found, '//TRIM(NuclideSpecs(DaughterNuclide)%NuclideName)& + endif ! Recognition of daughter by mother + enddo ! loop over daughters + enddo ! Loop over candidate mothers + + if (DebugLevel > 0) then + if (NMothers > 0) then + write(*,'(A,I0,A)') 'Found ',NMothers,' mothers for '//trim(NuclideSpecs(DaughterNuclide)%NuclideName)//'!' + else + write(*,'(A)') 'No mothers were found, '//trim(NuclideSpecs(DaughterNuclide)%NuclideName)& & //' is an artificial nuclide and not a decay product!' - ENDIF + endif - WRITE(*,'(A)') 'This is all I wanted to say about too fast nuclide '& - & //TRIM(NuclideSpecs(DaughterNuclide)%NuclideName) - ENDIF ! DebugLevel > 0 - ENDIF ! Halflife of daughter too short - ENDDO ! Loop over daughters + write(*,'(A)') 'This is all I wanted to say about too fast nuclide '& + & //trim(NuclideSpecs(DaughterNuclide)%NuclideName) + endif ! DebugLevel > 0 + endif ! Halflife of daughter too short + enddo ! Loop over daughters ! ! Show list of orphans ! - WRITE(*,'(A)') 'List of orphans: ' + write(*,'(A)') 'List of orphans: ' - DO iOrphan = 1,Orphanage%NOrphans - WRITE(*,'(A,I4,A,A,A,A,5X,A,EN20.10,A,F20.10,A)') & + do iOrphan = 1,Orphanage%NOrphans + write(*,'(A,I4,A,A,A,A,5X,A,EN20.10,A,F20.10,A)') & & 'Orphanage%Orphan ',iOrphan,' is daughter ',& & NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%NuclideName,& & ' from mother ',& @@ -1790,57 +1784,57 @@ SUBROUTINE FindOrphans(tMin) & 'because halflife ',& & NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%HalfTime,& & '[s] < limit ',Orphanage%tMin,'[s]' - ENDDO ! loop over orphans + enddo ! loop over orphans - WRITE(*,'(A)') 'Ready looking for orphan nuclides!' - END SUBROUTINE FindOrphans + write(*,'(A)') 'Ready looking for orphan nuclides!' + end subroutine FindOrphans - SUBROUTINE RegularizeNuclides(MyNuclideSpecs) + subroutine RegularizeNuclides(MyNuclideSpecs) ! ! All orphan nuclides with halftime shorter than Orphanage%tMin are eliminated. ! Their contributions are attributed to the mother nuclide decaying directly to the grand-daughters. ! - TYPE(NuclideType), DIMENSION(0:MaxNuclides), INTENT(INOUT) :: MyNuclideSpecs + type(NuclideType), dimension(0:MaxNuclides), intent(inout) :: MyNuclideSpecs - INTEGER :: DaughterNuclide,NGrandDaughters,iGrandDaughter,GrandDaughterNuclide,NMothers,MotherNuclide,iDaughter,& + integer :: DaughterNuclide,NGrandDaughters,iGrandDaughter,GrandDaughterNuclide,NMothers,MotherNuclide,iDaughter,& & HerDaughterNuclide,FreeDaughter,iNuclide - LOGICAL :: IsAlreadyADaughter,IsFirstFreeSlot + logical :: IsAlreadyADaughter,IsFirstFreeSlot - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - WRITE(*,*) - WRITE(*,'(A,EN20.10,A)') 'Going to eliminate all nuclides with halflife faster than ',Orphanage%tMin,' s' - WRITE(*,*) + write(*,*) + write(*,'(A,EN20.10,A)') 'Going to eliminate all nuclides with halflife faster than ',Orphanage%tMin,' s' + write(*,*) ! ! "DaughterNuclide" is the possibly too fast nuclide, i.e. an orphan nuclide, that has to be brushed under the carpet. ! - DO DaughterNuclide = 1,NNuclides - IF (Orphanage%IsTooUnstable(DaughterNuclide)) THEN - IF (DebugLevel.GT.0) WRITE(*,'(A,EN20.10,A)') 'Handling too fast nuclide '& - & //TRIM(MyNuclideSpecs(DaughterNuclide)%NuclideName)//' with halflife ',& + do DaughterNuclide = 1,NNuclides + if (Orphanage%IsTooUnstable(DaughterNuclide)) then + if (DebugLevel > 0) write(*,'(A,EN20.10,A)') 'Handling too fast nuclide '& + & //trim(MyNuclideSpecs(DaughterNuclide)%NuclideName)//' with halflife ',& & MyNuclideSpecs(DaughterNuclide)%HalfTime,& & ' s' ! ! Count number of granddaughters that is formed and that we have to re-arrange ! - WRITE(*,'(A)') 'Going to search for radioactive granddaughters...' + write(*,'(A)') 'Going to search for radioactive granddaughters...' NGrandDaughters = 0 - DO iGrandDaughter = 1,MaxNDaughters + do iGrandDaughter = 1,MaxNDaughters GrandDaughterNuclide = MyNuclideSpecs(DaughterNuclide)%Daughter(iGrandDaughter) - IF (GrandDaughterNuclide.GT.0) THEN - WRITE(*,'(A)') 'Spotted radioactive granddaughter '& + if (GrandDaughterNuclide > 0) then + write(*,'(A)') 'Spotted radioactive granddaughter '& & //MyNuclideSpecs(GrandDaughterNuclide)%NuclideName NGrandDaughters = NGrandDaughters + 1 - ENDIF - ENDDO - IF (NGrandDaughters.GT.0) THEN - WRITE(*,'(A,I0,A)') 'This daughter nuclide forms ',NGrandDaughters,' radioactive granddaughters' - ELSE - WRITE(*,'(A,I0,A)') 'This daughter nuclide forms no radioactive granddaughters, '& + endif + enddo + if (NGrandDaughters > 0) then + write(*,'(A,I0,A)') 'This daughter nuclide forms ',NGrandDaughters,' radioactive granddaughters' + else + write(*,'(A,I0,A)') 'This daughter nuclide forms no radioactive granddaughters, '& & //'I will only eliminate the formation of this nuclide' - ENDIF + endif ! ! Check all nuclides if they can be the mother of this orphan daughter ! @@ -1848,37 +1842,37 @@ SUBROUTINE RegularizeNuclides(MyNuclideSpecs) ! NMothers = 0 - DO MotherNuclide = 1,NNuclides - DO iDaughter = 1,MaxNDaughters + do MotherNuclide = 1,NNuclides + do iDaughter = 1,MaxNDaughters HerDaughterNuclide = MyNuclideSpecs(MotherNuclide)%Daughter(iDaughter) ! !############################################################################################################# ! ! If a possible mother has been found, eliminate the family relation and pass all info on to the next generation ! - IF (DaughterNuclide.EQ.HerDaughterNuclide) THEN + if (DaughterNuclide == HerDaughterNuclide) then NMothers = NMothers + 1 - WRITE(*,'(A,I0,A,F15.10)') 'Found mother '//TRIM(MyNuclideSpecs(MotherNuclide)%NuclideName)//& - & ' and '//TRIM(MyNuclideSpecs(DaughterNuclide)%NuclideName)//' is her daughter number ',& + write(*,'(A,I0,A,F15.10)') 'Found mother '//trim(MyNuclideSpecs(MotherNuclide)%NuclideName)//& + & ' and '//trim(MyNuclideSpecs(DaughterNuclide)%NuclideName)//' is her daughter number ',& & iDaughter,& & ' with branching ratio ',MyNuclideSpecs(MotherNuclide)%DaughterFraction(iDaughter) ! ! Pass heritage to granddaughters via daughter ! - WRITE(*,'(A)') 'Going to pass heritage of mother '& - & //TRIM(MyNuclideSpecs(MotherNuclide)%NuclideName)& + write(*,'(A)') 'Going to pass heritage of mother '& + & //trim(MyNuclideSpecs(MotherNuclide)%NuclideName)& & //' to her radioactive granddaughters...' - DO iGrandDaughter = 1,MyNuclideSpecs(DaughterNuclide)%NDaughters + do iGrandDaughter = 1,MyNuclideSpecs(DaughterNuclide)%NDaughters GrandDaughterNuclide = MyNuclideSpecs(DaughterNuclide)%Daughter(iGrandDaughter) - IF (GrandDaughterNuclide.GT.0) THEN + if (GrandDaughterNuclide > 0) then ! ! Found a grand-daughter ! - WRITE(*,'(A,I0,A,F15.10)') 'Found granddaughter '& - & //TRIM(MyNuclideSpecs(GrandDaughterNuclide)%NuclideName)& + write(*,'(A,I0,A,F15.10)') 'Found granddaughter '& + & //trim(MyNuclideSpecs(GrandDaughterNuclide)%NuclideName)& & //' with index ',iGrandDaughter,' and with branching ratio ',& & MyNuclideSpecs(DaughterNuclide)%DaughterFraction(iGrandDaughter) ! @@ -1886,34 +1880,34 @@ SUBROUTINE RegularizeNuclides(MyNuclideSpecs) ! IsAlreadyADaughter = .FALSE. FreeDaughter = 0 - DO iNuclide = 1,MaxNDaughters - IF (MyNuclideSpecs(MotherNuclide)%Daughter(iNuclide).EQ.GrandDaughterNuclide) THEN + do iNuclide = 1,MaxNDaughters + if (MyNuclideSpecs(MotherNuclide)%Daughter(iNuclide) == GrandDaughterNuclide) then FreeDaughter = iNuclide IsAlreadyADaughter = .TRUE. - ENDIF ! Granddaughter is already also a daughter - ENDDO + endif ! Granddaughter is already also a daughter + enddo ! ! If not already a daughter, find the first available new daughter slot ! - IF (FreeDaughter.EQ.0) THEN - DO iNuclide = 1,MaxNDaughters - IsFirstFreeSlot=((FreeDaughter.EQ.0).AND.(MyNuclideSpecs(MotherNuclide)%Daughter(iNuclide).EQ.0)) - IF (IsFirstFreeSlot) FreeDaughter = iNuclide - ENDDO - ENDIF ! granddaughter was not also a daughter - - IF (FreeDaughter.GT.0) THEN - IF (IsAlreadyADaughter) THEN - WRITE(*,'(A,I0,A)') 'Daughter slot ',FreeDaughter,& - & ' of mother '//TRIM(MyNuclideSpecs(MotherNuclide)%NuclideName)& - & //' already contained granddaughter '//TRIM(MyNuclideSpecs(GrandDaughterNuclide)%NuclideName)& + if (FreeDaughter == 0) then + do iNuclide = 1,MaxNDaughters + IsFirstFreeSlot=((FreeDaughter == 0).AND.(MyNuclideSpecs(MotherNuclide)%Daughter(iNuclide) == 0)) + if (IsFirstFreeSlot) FreeDaughter = iNuclide + enddo + endif ! granddaughter was not also a daughter + + if (FreeDaughter > 0) then + if (IsAlreadyADaughter) then + write(*,'(A,I0,A)') 'Daughter slot ',FreeDaughter,& + & ' of mother '//trim(MyNuclideSpecs(MotherNuclide)%NuclideName)& + & //' already contained granddaughter '//trim(MyNuclideSpecs(GrandDaughterNuclide)%NuclideName)& & //'! Adding contribution!' - WRITE(*,'(A,I0,A)') 'Augmenting branching ratio for old daughter '& - & //TRIM(MyNuclideSpecs(GrandDaughterNuclide)%NuclideName)& - & //' of mother '//TRIM(MyNuclideSpecs(MotherNuclide)%NuclideName)//' in daughter slot number ',& + write(*,'(A,I0,A)') 'Augmenting branching ratio for old daughter '& + & //trim(MyNuclideSpecs(GrandDaughterNuclide)%NuclideName)& + & //' of mother '//trim(MyNuclideSpecs(MotherNuclide)%NuclideName)//' in daughter slot number ',& & FreeDaughter,':' - WRITE(*,'(5(A,F15.10))') & + write(*,'(5(A,F15.10))') & & 'Adding ',MyNuclideSpecs(MotherNuclide)%DaughterFraction(iDaughter),& & ' x ',MyNuclideSpecs(DaughterNuclide)%DaughterFraction(iGrandDaughter),& & ' = ',MyNuclideSpecs(MotherNuclide )%DaughterFraction(iDaughter)& @@ -1928,13 +1922,13 @@ SUBROUTINE RegularizeNuclides(MyNuclideSpecs) & MyNuclideSpecs(MotherNuclide )%DaughterFraction(iDaughter )& & *MyNuclideSpecs(DaughterNuclide)%DaughterFraction(iGrandDaughter) - ELSE - WRITE(*,'(A,I0,A)') 'Daughter slot ',FreeDaughter,& + else + write(*,'(A,I0,A)') 'Daughter slot ',FreeDaughter,& & ' of mother is still free, adopting it for granddaughter!' - WRITE(*,'(A,I0)') 'Installing new daughter '& - & //TRIM(MyNuclideSpecs(GrandDaughterNuclide)%NuclideName)& - & //' of mother '//TRIM(MyNuclideSpecs(MotherNuclide)%NuclideName)//' in daughter slot number ',& + write(*,'(A,I0)') 'Installing new daughter '& + & //trim(MyNuclideSpecs(GrandDaughterNuclide)%NuclideName)& + & //' of mother '//trim(MyNuclideSpecs(MotherNuclide)%NuclideName)//' in daughter slot number ',& & FreeDaughter MyNuclideSpecs(MotherNuclide)%Daughter(FreeDaughter) = & @@ -1947,76 +1941,76 @@ SUBROUTINE RegularizeNuclides(MyNuclideSpecs) & MyNuclideSpecs(MotherNuclide )%DaughterFraction(iDaughter )& & *MyNuclideSpecs(DaughterNuclide)%DaughterFraction(iGrandDaughter) - ENDIF - ELSE - WRITE(*,'(A)') 'Somehow I cannot find a free daughter...' - CALL EXIT() - ENDIF + endif + else + write(*,'(A)') 'Somehow I cannot find a free daughter...' + call exit() + endif - ENDIF - ENDDO ! loop over granddaughters + endif + enddo ! loop over granddaughters ! ! Eliminate the decay from this mother to the daughter at hand in the nuclide database: ! - WRITE(*,'(A,I0,A)') 'Eliminating daughter slot ',iDaughter,' of mother!' + write(*,'(A,I0,A)') 'Eliminating daughter slot ',iDaughter,' of mother!' MyNuclideSpecs(MotherNuclide)%Daughter(iDaughter) = 0 MyNuclideSpecs(MotherNuclide)%DaughterFraction(iDaughter) = 0._Float MyNuclideSpecs(MotherNuclide)%DaughterName(iDaughter) = ' ' - ENDIF ! Recognition of daughter by mother + endif ! Recognition of daughter by mother ! ! End of bookkeeping of the removal of 1 orphan nuclide by adding its contributions to 1 of its mothers ! !############################################################################################################# ! - ENDDO ! loop over 20 daughters - ENDDO ! Loop over candidate mothers + enddo ! loop over 20 daughters + enddo ! Loop over candidate mothers - IF (NMothers.GT.0) THEN - WRITE(*,'(A,I0,A)') 'Found ',NMothers,' mothers!' - ELSE - WRITE(*,'(A)') 'No mothers were found, this is an artificial nuclide and not a decay product!' - ENDIF + if (NMothers > 0) then + write(*,'(A,I0,A)') 'Found ',NMothers,' mothers!' + else + write(*,'(A)') 'No mothers were found, this is an artificial nuclide and not a decay product!' + endif - WRITE(*,'(A)')'Ready handling too fast nuclide '//TRIM(MyNuclideSpecs(DaughterNuclide)%NuclideName) - WRITE(*,*) - ENDIF ! Halflife of daughter too short - ENDDO ! Loop over daughters + write(*,'(A)')'Ready handling too fast nuclide '//trim(MyNuclideSpecs(DaughterNuclide)%NuclideName) + write(*,*) + endif ! Halflife of daughter too short + enddo ! Loop over daughters ! ! Make IsRelated(Daughter,Mother) matrix for the regularized set ! RegularizedIsRelated = .FALSE. - DO MotherNuclide = 1,NNuclides - DO iDaughter = 1,MaxNDaughters + do MotherNuclide = 1,NNuclides + do iDaughter = 1,MaxNDaughters HerDaughterNuclide = MyNuclideSpecs(MotherNuclide)%Daughter(iDaughter) - IF (HerDaughterNuclide.NE.0) THEN + if (HerDaughterNuclide /= 0) then RegularizedIsRelated(HerDaughterNuclide,MotherNuclide) = .TRUE. - ENDIF - ENDDO - ENDDO + endif + enddo + enddo - WRITE(*,'(A)') 'Ready regularizing mother-daughter matrix!' - END SUBROUTINE RegularizeNuclides + write(*,'(A)') 'Ready regularizing mother-daughter matrix!' + end subroutine RegularizeNuclides - SUBROUTINE CollectProgeny(iNuclide,DoPrint) + subroutine CollectProgeny(iNuclide,DoPrint) !================================================================================================================ ! ! Collect all progeny of this nuclide, first the regular ones, then add the short-living ones. ! !================================================================================================================ - INTEGER, INTENT(IN) :: iNuclide - LOGICAL, INTENT(IN) :: DoPrint + integer, intent(in) :: iNuclide + logical, intent(in) :: DoPrint - INTEGER :: NAdded,MotherNuclide,DaughterNuclide,OrphanCounter,SwiftNuclide,NFarAdded - LOGICAL :: Ready,IsNewFamily,IsNewFarFamily + integer :: NAdded,MotherNuclide,DaughterNuclide,OrphanCounter,SwiftNuclide,NFarAdded + logical :: Ready,IsNewFamily,IsNewFarFamily - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - IF (DoPrint) WRITE(*,'(A,I0,A,EN20.10,A)') 'Collecting the progeny family for nuclide ',iNuclide,& + if (DoPrint) write(*,'(A,I0,A,EN20.10,A)') 'Collecting the progeny family for nuclide ',iNuclide,& & ': '//NuclideSpecs(iNuclide)%NuclideName//' with halflife ',NuclideSpecs(iNuclide)%HalfTime,' [s]:' NuclideFamily%NFamily = 1 ! i.e.: the mother nuclide @@ -2038,17 +2032,17 @@ SUBROUTINE CollectProgeny(iNuclide,DoPrint) ! Ready = .FALSE. - DO WHILE (.NOT.Ready) + do while (.NOT.Ready) NAdded = 0 NFarAdded = 0 ! ! Loop over possible mothers ! - DO MotherNuclide = 1,NNuclides + do MotherNuclide = 1,NNuclides ! ! Loop over possible daughters ! - DO DaughterNuclide = 1,NNuclides + do DaughterNuclide = 1,NNuclides ! ! First check if this nuclide is part of the full family tree, including orphans ! The search is downward in the tree, so new members are identified if the mother is already a member, @@ -2057,24 +2051,24 @@ SUBROUTINE CollectProgeny(iNuclide,DoPrint) IsNewFarFamily = (IsRelated(DaughterNuclide,MotherNuclide) & & .AND. NuclideFamily%IsFarFamily(MotherNuclide) & & .AND. (.NOT.NuclideFamily%IsFarFamily(DaughterNuclide))& - & .AND. (NuclideSpecs(DaughterNuclide)%HalfTime.LT.1.E80_Float)) + & .AND. (NuclideSpecs(DaughterNuclide)%HalfTime < 1.E80_Float)) - IF (IsNewFarFamily) THEN + if (IsNewFarFamily) then NuclideFamily%IsFarFamily(DaughterNuclide) = .TRUE. NFarAdded = NFarAdded + 1 NuclideFamily%NFarFamily = NuclideFamily%NFarFamily + 1 - ENDIF + endif ! ! Now check if it is part of the narrow family of non-orphans and update bookkeeping if affirmative ! IsNewFamily = (RegularizedIsRelated(DaughterNuclide,MotherNuclide) & & .AND. NuclideFamily%IsFamily(MotherNuclide) & & .AND. (.NOT.NuclideFamily%IsFamily(DaughterNuclide))& - & .AND. (NuclideSpecs(DaughterNuclide)%HalfTime.LT.1.E80_Float)) + & .AND. (NuclideSpecs(DaughterNuclide)%HalfTime < 1.E80_Float)) ! ! Add new family member ! - IF (IsNewFamily) THEN + if (IsNewFamily) then NuclideFamily%IsFamily(DaughterNuclide) = .TRUE. NAdded = NAdded + 1 NuclideFamily%NFamily = NuclideFamily%NFamily + 1 @@ -2089,46 +2083,46 @@ SUBROUTINE CollectProgeny(iNuclide,DoPrint) NuclideFamily%Mother(DaughterNuclide,NuclideFamily%NMothers(DaughterNuclide)) = & & MotherNuclide - IF (DebugLevel.GT.2) THEN - WRITE(*,'(A)') 'Adding daughter '//NuclideSpecs(DaughterNuclide)%NuclideName//' for mother '//& + if (DebugLevel > 2) then + write(*,'(A)') 'Adding daughter '//NuclideSpecs(DaughterNuclide)%NuclideName//' for mother '//& & NuclideSpecs(MotherNuclide)%NuclideName - ENDIF - ELSE IF (IsNewFarFamily) THEN - IF (DebugLevel.GT.2) THEN - WRITE(*,'(A)') 'Adding orphan daughter '//NuclideSpecs(DaughterNuclide)%NuclideName//' for mother '//& + endif + else if (IsNewFarFamily) then + if (DebugLevel > 2) then + write(*,'(A)') 'Adding orphan daughter '//NuclideSpecs(DaughterNuclide)%NuclideName//' for mother '//& & NuclideSpecs(MotherNuclide)%NuclideName - ENDIF - ENDIF - ENDDO ! loop over all other nuclides - ENDDO ! loop over nuclides already in the family - - Ready = (NFarAdded .EQ. 0) - - IF (DebugLevel.GT.2) THEN - IF (Ready) THEN - WRITE(*,'(A)') 'Found no new members, halting iterations!' - ELSE - WRITE(*,'(A,I0,A,I0,A)') 'Found ',NFarAdded,' new members, of which ',NFarAdded-NAdded,' core members!'& + endif + endif + enddo ! loop over all other nuclides + enddo ! loop over nuclides already in the family + + Ready = (NFarAdded == 0) + + if (DebugLevel > 2) then + if (Ready) then + write(*,'(A)') 'Found no new members, halting iterations!' + else + write(*,'(A,I0,A,I0,A)') 'Found ',NFarAdded,' new members, of which ',NFarAdded-NAdded,' core members!'& & //' Proceeding with next iteration!' - ENDIF - ENDIF - ENDDO ! while loop + endif + endif + enddo ! while loop ! ! Now add short living family members ! - IF (DebugLevel.GT.2) THEN - WRITE(*,'(A)') 'The regular family has been formed, now going to add possible fast nuclides!' - ENDIF + if (DebugLevel > 2) then + write(*,'(A)') 'The regular family has been formed, now going to add possible fast nuclides!' + endif OrphanCounter = NuclideFamily%NFamily NAdded = 0 - DO SwiftNuclide = 1,NNuclides - IF (NuclideFamily%IsFarFamily(SwiftNuclide).AND..NOT.(NuclideFamily%IsFamily(SwiftNuclide))) THEN - IF (DebugLevel.GT.2) THEN - WRITE(*,'(A)') 'Nuclide '//TRIM(NuclideSpecs(SwiftNuclide)%NuclideName)//' seems interesting! Adding it!' - ENDIF + do SwiftNuclide = 1,NNuclides + if (NuclideFamily%IsFarFamily(SwiftNuclide).AND..NOT.(NuclideFamily%IsFamily(SwiftNuclide))) then + if (DebugLevel > 2) then + write(*,'(A)') 'Nuclide '//trim(NuclideSpecs(SwiftNuclide)%NuclideName)//' seems interesting! Adding it!' + endif NAdded = NAdded + 1 @@ -2139,99 +2133,99 @@ SUBROUTINE CollectProgeny(iNuclide,DoPrint) ! ! Register its daughters ! - DO DaughterNuclide = 1,NNuclides - IF (IsRelated(DaughterNuclide,SwiftNuclide)) THEN + do DaughterNuclide = 1,NNuclides + if (IsRelated(DaughterNuclide,SwiftNuclide)) then NuclideFamily%NDaughters(SwiftNuclide) = NuclideFamily%NDaughters(SwiftNuclide) + 1 NuclideFamily%Daughter(SwiftNuclide,NuclideFamily%NDaughters(SwiftNuclide)) = & & DaughterNuclide - ENDIF - ENDDO ! loop over possible mothers + endif + enddo ! loop over possible mothers ! ! Register its mothers ! - DO MotherNuclide = 1,NNuclides - IF (IsRelated(SwiftNuclide,MotherNuclide)) THEN + do MotherNuclide = 1,NNuclides + if (IsRelated(SwiftNuclide,MotherNuclide)) then NuclideFamily%NMothers(SwiftNuclide) = NuclideFamily%NMothers(SwiftNuclide) + 1 NuclideFamily%Mother(SwiftNuclide,NuclideFamily%NMothers(SwiftNuclide)) = & & MotherNuclide - ENDIF - ENDDO ! loop over possible mothers - ENDIF ! This is such a swift nuclide - ENDDO ! loop over possibly fast decaying nuclides that have to be added to the family, but with high index numbers + endif + enddo ! loop over possible mothers + endif ! This is such a swift nuclide + enddo ! loop over possibly fast decaying nuclides that have to be added to the family, but with high index numbers - Ready = (NAdded .EQ. 0) + Ready = (NAdded == 0) - IF (DebugLevel.GT.2) THEN - WRITE(*,'(A,I0,A)') 'Found ',NAdded,' new too fast (orphan) members!' - ENDIF + if (DebugLevel > 2) then + write(*,'(A,I0,A)') 'Found ',NAdded,' new too fast (orphan) members!' + endif ! ! Show all relatives for this nuclide ! - IF (DebugLevel.EQ.1) THEN - WRITE(*,'(A)') NuclideSpecs(iNuclide)%NuclideName//' chain:' - DO DaughterNuclide = 1,NNuclides - IF(DaughterNuclide.NE.iNuclide) THEN - IF(NuclideFamily%IsFamily(DaughterNuclide)) THEN - WRITE(*,'(5X,A)') NuclideSpecs(DaughterNuclide)%NuclideName - ELSE IF (NuclideFamily%IsFarFamily(DaughterNuclide)) THEN - WRITE(*,'(5X,A)') NuclideSpecs(DaughterNuclide)%NuclideName//' <-- orphan' - ENDIF - ENDIF ! Daughter not iNuclide - ENDDO - ELSEIF ((DebugLevel.GT.1).AND. DoPrint) THEN - WRITE(*,'(A,I0,A)') 'This nuclide has a family with ',NuclideFamily%NFarFamily-1,' more members:' - DO DaughterNuclide = 1,NNuclides - IF (DebugLevel.GT.2) THEN - WRITE(*,'(4A,2L5)') 'CollectProgeny: show all relatives: ',NuclideSpecs(iNuclide)%NuclideName,& + if (DebugLevel == 1) then + write(*,'(A)') NuclideSpecs(iNuclide)%NuclideName//' chain:' + do DaughterNuclide = 1,NNuclides + if(DaughterNuclide /= iNuclide) then + if(NuclideFamily%IsFamily(DaughterNuclide)) then + write(*,'(5X,A)') NuclideSpecs(DaughterNuclide)%NuclideName + else if (NuclideFamily%IsFarFamily(DaughterNuclide)) then + write(*,'(5X,A)') NuclideSpecs(DaughterNuclide)%NuclideName//' <-- orphan' + endif + endif ! Daughter not iNuclide + enddo + elseif ((DebugLevel > 1).AND. DoPrint) then + write(*,'(A,I0,A)') 'This nuclide has a family with ',NuclideFamily%NFarFamily-1,' more members:' + do DaughterNuclide = 1,NNuclides + if (DebugLevel > 2) then + write(*,'(4A,2L5)') 'CollectProgeny: show all relatives: ',NuclideSpecs(iNuclide)%NuclideName,& & ' --> ? ',NuclideSpecs(DaughterNuclide)%NuclideName,& & NuclideFamily%IsFamily(DaughterNuclide),NuclideFamily%IsFarFamily(DaughterNuclide) - ENDIF + endif - IF(DaughterNuclide.NE.iNuclide) THEN - IF(NuclideFamily%IsFamily(DaughterNuclide)) THEN - WRITE(*,'(A,EN20.10,A)') NuclideSpecs(DaughterNuclide)%NuclideName//' with halflife ',& + if(DaughterNuclide /= iNuclide) then + if(NuclideFamily%IsFamily(DaughterNuclide)) then + write(*,'(A,EN20.10,A)') NuclideSpecs(DaughterNuclide)%NuclideName//' with halflife ',& & NuclideSpecs(DaughterNuclide)%HalfTime,' [s]' - ELSE IF (NuclideFamily%IsFarFamily(DaughterNuclide)) THEN - WRITE(*,'(A,EN20.10,A)') NuclideSpecs(DaughterNuclide)%NuclideName//' with halflife ',& + else if (NuclideFamily%IsFarFamily(DaughterNuclide)) then + write(*,'(A,EN20.10,A)') NuclideSpecs(DaughterNuclide)%NuclideName//' with halflife ',& & NuclideSpecs(DaughterNuclide)%HalfTime,' [s] <-- orphan' - ENDIF - ENDIF ! Daughter not iNuclide - ENDDO - ENDIF - END SUBROUTINE CollectProgeny + endif + endif ! Daughter not iNuclide + enddo + endif + end subroutine CollectProgeny - SUBROUTINE ListTransitions() + subroutine ListTransitions() ! ! List all transitions that take place within 1 family, including orphans ! - INTEGER :: MotherNuclide,DaughterNuclide,iDaughter,MAtom,DAtom + integer :: MotherNuclide,DaughterNuclide,iDaughter,MAtom,DAtom - WRITE(*,*) - WRITE(*,'(A)') 'Transitions in family with head of chain '& + write(*,*) + write(*,'(A)') 'Transitions in family with head of chain '& & //NuclideSpecs(NuclideFamily%FamilyMember(1))%NuclideName//':' - DO MotherNuclide = 1,NNuclides - IF (NuclideFamily%IsFarFamily(MotherNuclide)) THEN - DO iDaughter = 1,NuclideSpecs(MotherNuclide)%NDaughters + do MotherNuclide = 1,NNuclides + if (NuclideFamily%IsFarFamily(MotherNuclide)) then + do iDaughter = 1,NuclideSpecs(MotherNuclide)%NDaughters DaughterNuclide = NuclideSpecs(MotherNuclide)%Daughter(iDaughter) - IF (DaughterNuclide.NE.0) THEN + if (DaughterNuclide /= 0) then ! ! Find type of transition ! MAtom = NuclideSpecs(MotherNuclide)%AtomNumber DAtom = NuclideSpecs(DaughterNuclide)%AtomNumber - WRITE(*,'(A,A,A30,A,A,A,F15.10)') & + write(*,'(A,A,A30,A,A,A,F15.10)') & & NuclideSpecs(MotherNuclide )%NuclideName,& - & ' --- ',TRIM(NuclideSpecs(MotherNuclide)%DecayName(iDaughter)),' --> ',& + & ' --- ',trim(NuclideSpecs(MotherNuclide)%DecayName(iDaughter)),' --> ',& & NuclideSpecs(DaughterNuclide)%NuclideName,& & ' fraction ',& & NuclideSpecs(MotherNuclide)%DaughterFraction(iDaughter) - ELSE IF ((LEN_TRIM(NuclideSpecs(MotherNuclide)%DaughterName(iDaughter)).GT.0)& - & .AND.(TRIM(NuclideSpecs(MotherNuclide)%DaughterName(iDaughter)).NE.'SF')) THEN - WRITE(*,'(4A,F15.10,A)') & + else if ((len_trim(NuclideSpecs(MotherNuclide)%DaughterName(iDaughter)) > 0)& + & .AND.(trim(NuclideSpecs(MotherNuclide)%DaughterName(iDaughter)) /= 'SF')) then + write(*,'(4A,F15.10,A)') & & NuclideSpecs(MotherNuclide)%NuclideName,& & ' ------------> ',& & NuclideSpecs(MotherNuclide)%DaughterName(iDaughter),& @@ -2239,53 +2233,49 @@ SUBROUTINE ListTransitions() & NuclideSpecs(MotherNuclide)%DaughterFraction(iDaughter),& & ' STABLE' - ENDIF - ENDDO - ENDIF ! mother is family - ENDDO - END SUBROUTINE ListTransitions + endif + enddo + endif ! mother is family + enddo + end subroutine ListTransitions - SUBROUTINE MakeEvolutionMatrix(iNuclide,RegularizedMotherDaughterMatrix,x,NSecondsDelay,zDelay) + subroutine MakeEvolutionMatrix(RegularizedMotherDaughterMatrix,x,NSecondsDelay,zDelay) !================================================================================================================ ! ! Construct exponential of mother/daughter matrix of this family ! !================================================================================================================ - INTEGER, INTENT(IN) :: iNuclide - REAL(Float), INTENT(IN) :: NSecondsDelay - REAL(Float), DIMENSION(MaxNuclides,MaxNuclides), INTENT(IN) :: RegularizedMotherDaughterMatrix - REAL(dp), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: zDelay - REAL(dp), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: x - - INTEGER :: MotherNuclide,DaughterNuclide,ErrorCode,iSecond,iMinute,iHour,iDay,jNuclide - REAL(dp), DIMENSION(:,:), ALLOCATABLE :: yDelay - CHARACTER(DefaultLength) :: MyFormat,FName + real(Float), intent(in) :: NSecondsDelay + real(Float), dimension(MaxNuclides,MaxNuclides), intent(in) :: RegularizedMotherDaughterMatrix + real(dp), dimension(:,:), allocatable, intent(out) :: zDelay + real(dp), dimension(:,:), allocatable, intent(out) :: x - INTEGER, PARAMETER :: DebugLevel = 0 + integer :: MotherNuclide,DaughterNuclide,ErrorCode + real(dp), dimension(:,:), allocatable :: yDelay - IF (ALLOCATED(x)) DEALLOCATE(x) - ALLOCATE(x(NuclideFamily%NFamily,NuclideFamily%NFamily)) + if (ALLOCATED(x)) deallocate(x) + allocate(x(NuclideFamily%NFamily,NuclideFamily%NFamily)) x = 0._Float - IF (ALLOCATED(yDelay)) DEALLOCATE(yDelay) - ALLOCATE(yDelay(NuclideFamily%NFamily,NuclideFamily%NFamily)) + if (ALLOCATED(yDelay)) deallocate(yDelay) + allocate(yDelay(NuclideFamily%NFamily,NuclideFamily%NFamily)) yDelay = 0._Float - IF (ALLOCATED(zDelay)) DEALLOCATE(zDelay) - ALLOCATE(zDelay(NuclideFamily%NFamily,NuclideFamily%NFamily)) + if (ALLOCATED(zDelay)) deallocate(zDelay) + allocate(zDelay(NuclideFamily%NFamily,NuclideFamily%NFamily)) zDelay = 0._Float ! ! Copy time-rate of change from large matrix for all nuclides to smaller matrix ! - DO MotherNuclide = 1,NuclideFamily%NFamily - DO DaughterNuclide = 1,NuclideFamily%NFamily + do MotherNuclide = 1,NuclideFamily%NFamily + do DaughterNuclide = 1,NuclideFamily%NFamily x(DaughterNuclide,MotherNuclide) = & & RegularizedMotherDaughterMatrix(NuclideFamily%FamilyMember(DaughterNuclide),& & NuclideFamily%FamilyMember(MotherNuclide)) - ENDDO - ENDDO + enddo + enddo ! ! Macroscopic time-step over 1 minute, 1 hour and 1 day ! @@ -2293,12 +2283,12 @@ SUBROUTINE MakeEvolutionMatrix(iNuclide,RegularizedMotherDaughterMatrix,x,NSecon ! ! Exponential ! - CALL dmexp(yDelay,NuclideFamily%NFamily,zDelay,ErrorCode) - END SUBROUTINE MakeEvolutionMatrix + call dmexp(yDelay,NuclideFamily%NFamily,zDelay,ErrorCode) + end subroutine MakeEvolutionMatrix - SUBROUTINE AddOrphansBelow(iNuclide,TheDecayMatrix,zDelay,NFirstMotherOrphans) + subroutine AddOrphansBelow(iNuclide,TheDecayMatrix,zDelay,NFirstMotherOrphans) !================================================================================================================ ! ! Modify a transition matrix to include the orphan transitions below this mother nuclide that have been short-circuited @@ -2306,23 +2296,23 @@ SUBROUTINE AddOrphansBelow(iNuclide,TheDecayMatrix,zDelay,NFirstMotherOrphans) ! i.e. the line in the transition matrix for element iNuclide. ! !================================================================================================================ - INTEGER, INTENT(IN) :: iNuclide - REAL(Float), DIMENSION(MaxNuclides,MaxNuclides), INTENT(INOUT) :: TheDecayMatrix - REAL(dp), DIMENSION(:,:), ALLOCATABLE, INTENT(INOUT) :: zDelay - INTEGER, INTENT(OUT) :: NFirstMotherOrphans + integer, intent(in) :: iNuclide + real(Float), dimension(MaxNuclides,MaxNuclides), intent(inout) :: TheDecayMatrix + real(dp), dimension(:,:), allocatable, intent(inout) :: zDelay + integer, intent(out) :: NFirstMotherOrphans - INTEGER :: iOrphan,NAdded,jOrphan,iIteration,iiNuclide,jjNuclide,MotherNuclide,& - & GhostNuclide,NAddedRegular,NAddedOrphans - LOGICAL :: Ready,NotAlreadyAMember,IsMotherOfNewOrphan,HaveCandidateMother,ItsMotherIs_ii - LOGICAL, DIMENSION(MaxNuclides) :: TooFastFullyChecked + integer :: iOrphan,NAdded,jOrphan,iIteration,iiNuclide,jjNuclide,MotherNuclide,& + & NAddedRegular,NAddedOrphans + logical :: Ready,NotAlreadyAMember,ItsMotherIs_ii + logical, dimension(MaxNuclides) :: TooFastFullyChecked - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - IF (DebugLevel.GT.0) WRITE(*,*) - IF (DebugLevel.GT.0) WRITE(*,'(A)') '-------------------- Start of search for orphan chain ------------------------' - IF (DebugLevel.GT.0) WRITE(*,*) - IF (DebugLevel.GT.0) WRITE(*,'(A,I4,A,A)') 'Checking orphan chain below nuclide ',iNuclide,& - & ' : ',TRIM(NuclideSpecs(iNuclide)%NuclideName) + if (DebugLevel > 0) write(*,*) + if (DebugLevel > 0) write(*,'(A)') '-------------------- Start of search for orphan chain ------------------------' + if (DebugLevel > 0) write(*,*) + if (DebugLevel > 0) write(*,'(A,I4,A,A)') 'Checking orphan chain below nuclide ',iNuclide,& + & ' : ',trim(NuclideSpecs(iNuclide)%NuclideName) NFirstMotherOrphans = 0 Orphanage%Orphan(:)%Active = .FALSE. ! None of the orphan transitions is yet recognized as relevant @@ -2332,108 +2322,108 @@ SUBROUTINE AddOrphansBelow(iNuclide,TheDecayMatrix,zDelay,NFirstMotherOrphans) Ready = .FALSE. iIteration = 0 - DO WHILE (.NOT.Ready) + do while (.NOT.Ready) iIteration = iIteration + 1 - IF (DebugLevel.GT.0) WRITE(*,*) - IF (DebugLevel.GT.0) WRITE(*,'(A,I0)') '############# Iteration ',iIteration + if (DebugLevel > 0) write(*,*) + if (DebugLevel > 0) write(*,'(A,I0)') '############# Iteration ',iIteration ! ! If any arrow into a too fast nuclide, either from regular progeny of the head of chain or from another ! too fast nuclide in the family, is inactive, switch off this daughter nuclide from TooFastFullyChecked ! - CALL MarkFullyCheckedOrphans() + call MarkFullyCheckedOrphans() ! ! Now fill in the gaps in the transition matrix for too fast nuclide ! - CALL AddOrphansFromRegularFamily(NAddedRegular) - CALL AddOrphansFromCheckedOrphans(NAddedOrphans) + call AddOrphansFromRegularFamily(NAddedRegular) + call AddOrphansFromCheckedOrphans(NAddedOrphans) NAdded = NAddedRegular + NAddedOrphans NFirstMotherOrphans = NFirstMotherOrphans + NAdded - IF (DebugLevel.GT.0) WRITE(*,'(A,I0)') 'Number of orphans added in this iteration: ',NAdded + if (DebugLevel > 0) write(*,'(A,I0)') 'Number of orphans added in this iteration: ',NAdded - Ready = (NAdded.EQ.0) + Ready = (NAdded == 0) - ENDDO ! loop until no new orphans added + enddo ! loop until no new orphans added - IF (DebugLevel.GT.0) WRITE(*,*) - IF (DebugLevel.GT.0) WRITE(*,'(A)') '-------------------- End of search for orphan chain --------------------------' - IF (DebugLevel.GT.0) WRITE(*,*) + if (DebugLevel > 0) write(*,*) + if (DebugLevel > 0) write(*,'(A)') '-------------------- End of search for orphan chain --------------------------' + if (DebugLevel > 0) write(*,*) - CONTAINS + contains - SUBROUTINE MarkFullyCheckedOrphans + subroutine MarkFullyCheckedOrphans TooFastFullyChecked = .TRUE. ! De-selection of non-fully checked too fast nuclides will be done immediately below - DO iOrphan = 1,Orphanage%NOrphans ! This loop includes all orphans, also the irrelevant ones not in this chain + do iOrphan = 1,Orphanage%NOrphans ! This loop includes all orphans, also the irrelevant ones not in this chain ! ! See if its mother is either regular progeny in the chain at hand (which needs to be addressed)... ! - DO MotherNuclide = 1,NuclideFamily%NFamily + do MotherNuclide = 1,NuclideFamily%NFamily iiNuclide = NuclideFamily%FamilyMember(MotherNuclide) - IF (Orphanage%Orphan(iOrphan)%Mother.EQ.iiNuclide) THEN ! So now the mother of the orphan is regular family + if (Orphanage%Orphan(iOrphan)%Mother == iiNuclide) then ! So now the mother of the orphan is regular family - IF (.NOT.Orphanage%Orphan(iOrphan)%Active) THEN ! but the transition to a too fast nuclide in not yet active + if (.NOT.Orphanage%Orphan(iOrphan)%Active) then ! but the transition to a too fast nuclide in not yet active TooFastFullyChecked(Orphanage%Orphan(iOrphan)%Daughter) = .FALSE. ! Then the too fast daughter is not yet a good basis for searching for new too fast progeny below - IF (DebugLevel.GT.0) WRITE(*,'(A,I0,A)') 'MarkFullyCheckedOrphans: In iteration ',iIteration,& + if (DebugLevel > 0) write(*,'(A,I0,A)') 'MarkFullyCheckedOrphans: In iteration ',iIteration,& & ' switched off orphan '& - & //TRIM(NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%NuclideName)& + & //trim(NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%NuclideName)& & //' for lack of progeny transition '& - & //TRIM(NuclideSpecs(Orphanage%Orphan(iOrphan)%Mother)%NuclideName)//' --> '& - & //TRIM(NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%NuclideName) - ENDIF + & //trim(NuclideSpecs(Orphanage%Orphan(iOrphan)%Mother)%NuclideName)//' --> '& + & //trim(NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%NuclideName) + endif - ENDIF ! We found the mother of this orphan in the regular progeny of the head of chain - ENDDO ! loop over mother nuclides + endif ! We found the mother of this orphan in the regular progeny of the head of chain + enddo ! loop over mother nuclides ! ! ... or a fully checked orphan that itself is in the big family ! - DO jOrphan = 1,Orphanage%NOrphans + do jOrphan = 1,Orphanage%NOrphans iiNuclide = Orphanage%Orphan(jOrphan)%Daughter - IF (NuclideFamily%IsFarFamily(iiNuclide)) THEN - IF (Orphanage%Orphan(iOrphan)%Mother.EQ.iiNuclide) THEN ! So now the mother of the orphan is an orphan + if (NuclideFamily%IsFarFamily(iiNuclide)) then + if (Orphanage%Orphan(iOrphan)%Mother == iiNuclide) then ! So now the mother of the orphan is an orphan - IF (.NOT.Orphanage%Orphan(iOrphan)%Active) THEN ! but this mother orphan transition is not yet active.. + if (.NOT.Orphanage%Orphan(iOrphan)%Active) then ! but this mother orphan transition is not yet active.. TooFastFullyChecked(Orphanage%Orphan(iOrphan)%Daughter) = .FALSE. ! then, de-select this nuclide - IF (DebugLevel.GT.0) WRITE(*,'(A,I0,A)') 'MarkFullyCheckedOrphans: In iteration ',& + if (DebugLevel > 0) write(*,'(A,I0,A)') 'MarkFullyCheckedOrphans: In iteration ',& & iIteration,' switched off orphan '& - & //TRIM(NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%NuclideName)& + & //trim(NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%NuclideName)& & //' for lack of orphan-orphan transition '& - & //TRIM(NuclideSpecs(Orphanage%Orphan(iOrphan)%Mother)%NuclideName)//' --> '& - & //TRIM(NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%NuclideName) - ENDIF - - ENDIF ! We found the mother of this orphan in the regular progeny of the head of chain - ENDIF ! Check if the mother of this orphan belongs to this (big) family - ENDDO ! loop over jOrphan - ENDDO ! loop over iOrphan - END SUBROUTINE MarkFullyCheckedOrphans - - SUBROUTINE AddOrphansFromRegularFamily(MyNAdded) - INTEGER, INTENT(OUT) :: MyNAdded + & //trim(NuclideSpecs(Orphanage%Orphan(iOrphan)%Mother)%NuclideName)//' --> '& + & //trim(NuclideSpecs(Orphanage%Orphan(iOrphan)%Daughter)%NuclideName) + endif + + endif ! We found the mother of this orphan in the regular progeny of the head of chain + endif ! Check if the mother of this orphan belongs to this (big) family + enddo ! loop over jOrphan + enddo ! loop over iOrphan + end subroutine MarkFullyCheckedOrphans + + subroutine AddOrphansFromRegularFamily(MyNAdded) + integer, intent(out) :: MyNAdded ! ! Step 1: Loop over all regular nuclides in this family to see if they have a yet inactive orphan in their progeny ! MyNAdded = 0 - DO MotherNuclide = 1,NuclideFamily%NFamily + do MotherNuclide = 1,NuclideFamily%NFamily iiNuclide = NuclideFamily%FamilyMember(MotherNuclide) ! ! Check all non-active orphans if they can originate from this mother ! - DO jOrphan = 1,Orphanage%NOrphans + do jOrphan = 1,Orphanage%NOrphans ! ! You found a new family member if any new orphan is not already a member and if the orphan at hand is the mother of the new orphan ! NotAlreadyAMember = (.NOT.Orphanage%Orphan(jOrphan)%Active) - ItsMotherIs_ii = (Orphanage%Orphan(jOrphan)%Mother.EQ.iiNuclide) + ItsMotherIs_ii = (Orphanage%Orphan(jOrphan)%Mother == iiNuclide) - IF (NotAlreadyAMember.AND.ItsMotherIs_ii) THEN + if (NotAlreadyAMember.AND.ItsMotherIs_ii) then Orphanage%Orphan(jOrphan)%Active = .TRUE. ! ! Modify transition matrix by adding the yield x activity of the mother of the orphan to the activity of the orphan @@ -2450,39 +2440,39 @@ SUBROUTINE AddOrphansFromRegularFamily(MyNAdded) MyNAdded = MyNAdded + 1 - IF (DebugLevel.GT.0) WRITE(*,'(A,F20.15)') 'AddOrphansFromRegularFamily: Found new orphan transition: '& + if (DebugLevel > 0) write(*,'(A,F20.15)') 'AddOrphansFromRegularFamily: Found new orphan transition: '& & //NuclideSpecs(jjNuclide)%NuclideName & & //' from mother '& & //NuclideSpecs(iiNuclide)%NuclideName& & //' with yield ',Orphanage%Orphan(jOrphan)%Yield - ENDIF - ENDDO ! loop over non-active orphans - ENDDO ! loop over all regular nuclides in this family - END SUBROUTINE AddOrphansFromRegularFamily + endif + enddo ! loop over non-active orphans + enddo ! loop over all regular nuclides in this family + end subroutine AddOrphansFromRegularFamily - SUBROUTINE AddOrphansFromCheckedOrphans(MyNAdded) - INTEGER, INTENT(OUT) :: MyNAdded + subroutine AddOrphansFromCheckedOrphans(MyNAdded) + integer, intent(out) :: MyNAdded ! ! Step 2: Loop over all fully checked orphan nuclides in this big family to see if they have a yet inactive orphan in their progeny ! MyNAdded = 0 - DO iOrphan = 1,Orphanage%NOrphans + do iOrphan = 1,Orphanage%NOrphans iiNuclide = Orphanage%Orphan(iOrphan)%Daughter ! i.e. the endpoint of an orphan arrow, the too fast nuclide itself - IF (NuclideFamily%IsFarFamily(iiNuclide)) THEN ! the too fast nuclide is far family! - IF (TooFastFullyChecked(iiNuclide)) THEN ! and all its incoming arrow have been accounted for, so not it can pass its activity to even lower decks! + if (NuclideFamily%IsFarFamily(iiNuclide)) then ! the too fast nuclide is far family! + if (TooFastFullyChecked(iiNuclide)) then ! and all its incoming arrow have been accounted for, so not it can pass its activity to even lower decks! ! ! Check all non-active orphans if they can originate from this (too fast) mother ! - DO jOrphan = 1,Orphanage%NOrphans + do jOrphan = 1,Orphanage%NOrphans ! ! You found a new family member if any new orphan is not already a member and if the orphan at hand is the mother of the new orphan ! NotAlreadyAMember = (.NOT.Orphanage%Orphan(jOrphan)%Active) - ItsMotherIs_ii = (Orphanage%Orphan(jOrphan)%Mother.EQ.iiNuclide) + ItsMotherIs_ii = (Orphanage%Orphan(jOrphan)%Mother == iiNuclide) - IF (NotAlreadyAMember.AND.ItsMotherIs_ii) THEN + if (NotAlreadyAMember.AND.ItsMotherIs_ii) then Orphanage%Orphan(jOrphan)%Active = .TRUE. ! ! Modify transition matrix by adding the yield x activity of the mother of the orphan to the activity of the orphan. @@ -2497,15 +2487,15 @@ SUBROUTINE AddOrphansFromCheckedOrphans(MyNAdded) MyNAdded = MyNAdded + 1 - IF (DebugLevel.GT.0) WRITE(*,'(A)') 'AddOrphansFromCheckedOrphans: Found new orphan transition: '& + if (DebugLevel > 0) write(*,'(A)') 'AddOrphansFromCheckedOrphans: Found new orphan transition: '& & //NuclideSpecs(jjNuclide)%NuclideName & & //' from mother '& & //NuclideSpecs(iiNuclide)%NuclideName - ENDIF - ENDDO ! loop over non-active orphans - ENDIF ! orphan active - ENDIF ! possible mother is an orphan herself that belongs to the big family - ENDDO ! loop over all active orphans - END SUBROUTINE AddOrphansFromCheckedOrphans - END SUBROUTINE AddOrphansBelow -END MODULE LibENDF + endif + enddo ! loop over non-active orphans + endif ! orphan active + endif ! possible mother is an orphan herself that belongs to the big family + enddo ! loop over all active orphans + end subroutine AddOrphansFromCheckedOrphans + end subroutine AddOrphansBelow +end module LibENDF diff --git a/src/lib/libinterval.f90 b/src/lib/libinterval.f90 index 0442a1b..6ae3966 100644 --- a/src/lib/libinterval.f90 +++ b/src/lib/libinterval.f90 @@ -1,37 +1,36 @@ -MODULE LibInterval +module LibInterval ! ! RIVM - National Institute for Public Health and the Environment ! ! PO Box 1, ! NL - 3720 BA Bilthoven ! The Netherlands - USE libxmath - USE libutil + use libxmath, only: Float - IMPLICIT NONE + implicit none - PRIVATE + private - PUBLIC :: IntervalSpecsType,& + public :: IntervalSpecsType,& & ExponentialIntervalType,ExponentialIntervalInterpolate - TYPE IntervalSpecsType - INTEGER :: N - REAL(Float) :: XMin,XMax - END TYPE IntervalSpecsType + type IntervalSpecsType + integer :: N + real(Float) :: XMin,XMax + end type IntervalSpecsType - TYPE ExponentialIntervalType - REAL(Float) :: FirstDelay,DelayGrowthFactor - TYPE(IntervalSpecsType) :: IntervalSpecs - REAL(Float), ALLOCATABLE, DIMENSION(:) :: Values - END TYPE ExponentialIntervalType + type ExponentialIntervalType + real(Float) :: FirstDelay,DelayGrowthFactor + type(IntervalSpecsType) :: IntervalSpecs + real(Float), allocatable, dimension(:) :: Values + end type ExponentialIntervalType ! - ! The following parameter can be set for debugging this MODULE + ! The following parameter can be set for debugging this module ! - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 -CONTAINS - FUNCTION ExponentialIntervalInterpolate(x,Interval,InterpolationWay,Error) +contains + function ExponentialIntervalInterpolate(x,Interval,InterpolationWay,Error) ! ! Give the interpolated value in a point arbitrary x>=0 of an interval with values at x=0 and at exponentially ! increasing x-values starting from a first delay. @@ -40,32 +39,32 @@ FUNCTION ExponentialIntervalInterpolate(x,Interval,InterpolationWay,Error) ! InterpolationWay = 1: linear and ! InterpolationWay = 2: powerlaw interpolation. ! - REAL(Float), INTENT(IN) :: x - TYPE(ExponentialIntervalType), INTENT(IN) :: Interval - INTEGER, INTENT(IN) :: InterpolationWay - LOGICAL, INTENT(OUT) :: Error - REAL(Float) :: ExponentialIntervalInterpolate + real(Float), intent(in) :: x + type(ExponentialIntervalType), intent(in) :: Interval + integer, intent(in) :: InterpolationWay + logical, intent(out) :: Error + real(Float) :: ExponentialIntervalInterpolate - REAL(Float) :: Dum,LocX,CellX,ThePower,XLeft,XRight,YLeft,YRight,dx - INTEGER :: i,NX,iLocX - LOGICAL :: BothAreNonZero + real(Float) :: Dum,LocX,CellX,ThePower,XLeft,XRight,YLeft,YRight + integer :: NX,iLocX + logical :: BothAreNonZero - INTEGER :: DebugLevel = 0 + integer :: DebugLevel = 0 Error = .FALSE. NX = Interval%IntervalSpecs%N - IF (DebugLevel.GT.0) WRITE(*,'(A,I0)') 'ExponentialIntervalInterpolate: NX = ',NX + if (DebugLevel > 0) write(*,'(A,I0)') 'ExponentialIntervalInterpolate: NX = ',NX - IF (x.LT.0._Float) THEN + if (x < 0._Float) then Dum = Interval%Values(0) Error = .TRUE. ! You are violating the conditions! - IF (DebugLevel.GT.0) WRITE(*,'(A,F15.5)') 'ExponentialIntervalInterpolate: 1: ',Dum - ELSE IF (x.GT.Interval%IntervalSpecs%XMax) THEN + if (DebugLevel > 0) write(*,'(A,F15.5)') 'ExponentialIntervalInterpolate: 1: ',Dum + else if (x > Interval%IntervalSpecs%XMax) then Dum = Interval%Values(NX) Error = .TRUE. ! You are violating the conditions! - IF (DebugLevel.GT.0) WRITE(*,'(A,F15.5)') 'ExponentialIntervalInterpolate: 2: ',Dum - ELSE IF (x.LT.Interval%FirstDelay) THEN + if (DebugLevel > 0) write(*,'(A,F15.5)') 'ExponentialIntervalInterpolate: 2: ',Dum + else if (x < Interval%FirstDelay) then ! ! For any x in [0,FirstDelay> use first order interpolation y = ax + b, irrespective of the given interpolation order ! @@ -79,84 +78,84 @@ FUNCTION ExponentialIntervalInterpolate(x,Interval,InterpolationWay,Error) ! ! Find the indices of the two samples around x: iLocX and iLocX+1 ! - ELSE + else LocX = 1._Float + LOG(x/Interval%FirstDelay)/LOG(Interval%DelayGrowthFactor) iLocX = MAX(MIN(INT(LocX),NX-1),1) - IF (DebugLevel.GT.0) WRITE(*,'(A,I0)') 'ExponentialIntervalInterpolate: iLocX = ',iLocX - CALL FLUSH(6) + if (DebugLevel > 0) write(*,'(A,I0)') 'ExponentialIntervalInterpolate: iLocX = ',iLocX + call FLUSH(6) XLeft = Interval%FirstDelay*Interval%DelayGrowthFactor**(iLocX-1) XRight = XLeft*Interval%DelayGrowthFactor YLeft = Interval%Values(iLocX) YRight = Interval%Values(iLocX+1) - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,F15.2)') 'ExponentialIntervalInterpolate: XLeft = ',XLeft - WRITE(*,'(A,F15.2)') 'ExponentialIntervalInterpolate: XRight = ',XRight - WRITE(*,'(A,F15.2)') 'ExponentialIntervalInterpolate: YLeft = ',YLeft - WRITE(*,'(A,F15.2)') 'ExponentialIntervalInterpolate: YRight = ',YRight - CALL FLUSH(6) - ENDIF + if (DebugLevel > 0) then + write(*,'(A,F15.2)') 'ExponentialIntervalInterpolate: XLeft = ',XLeft + write(*,'(A,F15.2)') 'ExponentialIntervalInterpolate: XRight = ',XRight + write(*,'(A,F15.2)') 'ExponentialIntervalInterpolate: YLeft = ',YLeft + write(*,'(A,F15.2)') 'ExponentialIntervalInterpolate: YRight = ',YRight + call FLUSH(6) + endif ! ! Powerlaw interpolation will not work if 1 of the y-values is 0. In that case use linear interpolation. ! - BothAreNonZero = (ABS(YLeft*YRight).GT.0._Float) - IF (DebugLevel.GT.0) WRITE(*,'(A,L1)') 'ExponentialIntervalInterpolate: BothAreNonZero? ',BothAreNonZero - CALL FLUSH(6) + BothAreNonZero = (abs(YLeft*YRight) > 0._Float) + if (DebugLevel > 0) write(*,'(A,L1)') 'ExponentialIntervalInterpolate: BothAreNonZero? ',BothAreNonZero + call FLUSH(6) ! ! Nearest neighbour interpolation ! - IF (InterpolationWay.EQ.0) THEN + if (InterpolationWay == 0) then CellX = (x-XLeft)/(XRight-XLeft) - IF (CellX.LE.0.5_Float) THEN + if (CellX <= 0.5_Float) then Dum = YLeft - ELSE + else Dum = YRight - ENDIF - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,F10.2,A,EN20.10)') 'ExponentialIntervalInterpolate: Order 0, CellX = ',CellX,' Dum = ',Dum - CALL FLUSH(6) - ENDIF - ELSE IF ((InterpolationWay.EQ.1).OR.(.NOT.BothAreNonZero)) THEN + endif + if (DebugLevel > 0) then + write(*,'(A,F10.2,A,EN20.10)') 'ExponentialIntervalInterpolate: Order 0, CellX = ',CellX,' Dum = ',Dum + call FLUSH(6) + endif + else if ((InterpolationWay == 1).OR.(.NOT.BothAreNonZero)) then ! ! Linear interpolation y = ax + b ! CellX = (x-XLeft)/(XRight-XLeft) Dum = (1._Float-CellX) * YLeft + CellX *YRight - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,F10.2,A,EN20.10)') 'ExponentialIntervalInterpolate: Linear: CellX = ',CellX,' Dum = ',Dum - CALL FLUSH(6) - ENDIF - ELSE IF (InterpolationWay.EQ.2) THEN + if (DebugLevel > 0) then + write(*,'(A,F10.2,A,EN20.10)') 'ExponentialIntervalInterpolate: Linear: CellX = ',CellX,' Dum = ',Dum + call FLUSH(6) + endif + else if (InterpolationWay == 2) then ! ! Powerlaw y = ax^b ! - IF (BothAreNonZero) THEN + if (BothAreNonZero) then ThePower = LOG(YRight/YLeft)/LOG(XRight/XLeft) Dum = YLeft * (x/XLeft)**ThePower - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,F10.2,A,EN20.10)') 'ExponentialIntervalInterpolate: Powerlaw: ThePower = ',& + if (DebugLevel > 0) then + write(*,'(A,F10.2,A,EN20.10)') 'ExponentialIntervalInterpolate: Powerlaw: ThePower = ',& & ThePower,' Dum = ',Dum - CALL FLUSH(6) - ENDIF - ELSE - WRITE(*,'(A)') 'ExponentialIntervalInterpolate: You are not supposed to end up here...' - ENDIF - ELSE - WRITE(*,'(A,I0)') 'Invalid value for InterpolationWay : ',InterpolationWay - CALL EXIT() - ENDIF - ENDIF + call FLUSH(6) + endif + else + write(*,'(A)') 'ExponentialIntervalInterpolate: You are not supposed to end up here...' + endif + else + write(*,'(A,I0)') 'Invalid value for InterpolationWay : ',InterpolationWay + call exit() + endif + endif ! ! Neglect very small values to avoid the possible writing of a number with an exponent that has 3 digits: ! the "E" is omitted in such cases, making the output unreadable for other programs... ! - IF (ABS(Dum).LT.1.E-95_Float) Dum = 0._Float + if (abs(Dum) < 1.E-95_Float) Dum = 0._Float ExponentialIntervalInterpolate = Dum - END FUNCTION ExponentialIntervalInterpolate -END MODULE LibInterval + end function ExponentialIntervalInterpolate +end module LibInterval diff --git a/src/lib/libpinpoint.f90 b/src/lib/libpinpoint.f90 index b20c762..b5715e7 100644 --- a/src/lib/libpinpoint.f90 +++ b/src/lib/libpinpoint.f90 @@ -1,4 +1,4 @@ -MODULE LibPinPoint +module LibPinPoint ! ____________________________________________________ ! ! Developed For: @@ -12,312 +12,314 @@ MODULE LibPinPoint ! ! ____________________________________________________ ! - USE libxmath - USE libutil - USE libdcc - USE libendf - - IMPLICIT NONE - - PRIVATE - - PUBLIC :: CocktailType,InitLibPinPoint,NStartingTimes,StartingTimeName,& + use LibDCC, only: DCCEffectiveDose, DCCGround, DCCInhalation, DCCThyroidInhalation, & + InitLibDCC, & + InAir, Age_Adult, Inhalation_public_adult, & + ReadTissueDCCs, ReadDCCEffectiveDose, ReadGroundDCCs, ReadInhalationDCCs, ReadThyroidInhalationDCCs + use LibENDF, only: MaxNuclides, NNuclides, NuclideSpecs, GetNuclideNumber, & + MotherDaughterMatrix, & + MassNuc2NucMass, EnsureHyphen, & + TransitionMatrixPath + use LibUtil, only: DefaultLength, ScratchFile, & + AllUpCase + use LibXMath, only: Float, SparseMatrix + + implicit none + + private + + public :: CocktailType,InitLibPinPoint,NStartingTimes,StartingTimeName,& & AvailableDelay,TransitionMatrix,GetPinpointCocktails,& & MakePinpointDoseRates,ReadRIVMSourceTermFile,SaveCocktail2,FirstDelay,DelayGrowthFactor,MatureCocktail - TYPE CocktailType - CHARACTER(DefaultLength) :: MyName,MyDirectory - REAL(Float), DIMENSION(MaxNuclides) :: x - END TYPE CocktailType - - CHARACTER(DefaultLength) :: ProjectPath = './' + type CocktailType + character(DefaultLength) :: MyName,MyDirectory + real(Float), dimension(MaxNuclides) :: x + end type CocktailType - REAL(Float), PARAMETER :: FirstDelay = 60._Float ! seconds - REAL(Float), PARAMETER :: DelayGrowthFactor = 1.15_Float - INTEGER, PARAMETER :: NStartingTimes = 200 ! There is also pinpoint 0, which is 0 + real(Float), parameter :: FirstDelay = 60._Float ! seconds + real(Float), parameter :: DelayGrowthFactor = 1.15_Float + integer, parameter :: NStartingTimes = 200 ! There is also pinpoint 0, which is 0 - CHARACTER(15), DIMENSION(0:NStartingTimes) :: StartingTimeName - REAL(Float), DIMENSION(0:NStartingTimes) :: AvailableDelay ! In seconds + character(15), dimension(0:NStartingTimes) :: StartingTimeName + real(Float), dimension(0:NStartingTimes) :: AvailableDelay ! In seconds - TYPE(SparseMatrix), DIMENSION(0:NStartingTimes) :: TransitionMatrix + type(SparseMatrix), dimension(0:NStartingTimes) :: TransitionMatrix -CONTAINS - SUBROUTINE InitLibPinPoint(UseICRP) +contains + subroutine InitLibPinPoint(UseICRP) ! ! Prepare some settings before use of this library ! - LOGICAL, INTENT(IN) :: UseICRP + logical, intent(in) :: UseICRP - INTEGER :: iStartingTime - REAL(Float) :: tMin - TYPE(NuclideType), DIMENSION(0:MaxNuclides) :: RegularizedNuclideSpecs - REAL(Float), DIMENSION(MaxNuclides,MaxNuclides) :: RegularizedMotherDaughterMatrix + integer :: iStartingTime - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 ! ! Get the DCCs ! - CALL InitLibDCC(UseICRP) ! includes reading data from ICRP or ENDF - CALL ReadTissueDCCs() - CALL ReadDCCEffectiveDose() - CALL ReadGroundDCCs() - CALL ReadInhalationDCCs() - CALL ReadThyroidInhalationDCCs() + call InitLibDCC(UseICRP) ! includes reading data from ICRP or ENDF + call ReadTissueDCCs() + call ReadDCCEffectiveDose() + call ReadGroundDCCs() + call ReadInhalationDCCs() + call ReadThyroidInhalationDCCs() AvailableDelay(0) = 0 AvailableDelay(1) = 60 - DO iStartingTime = 2,NStartingTimes + do iStartingTime = 2,NStartingTimes AvailableDelay(iStartingTime) = DelayGrowthFactor*AvailableDelay(iStartingTime-1) - ENDDO ! loop over starting times + enddo ! loop over starting times - IF (DebugLevel.GT.0) WRITE(*,*) - IF (DebugLevel.GT.0) WRITE(*,'(A)') 'Considering the following exponentially distributed delays:' - DO iStartingTime = 0,NStartingTimes - WRITE(StartingTimeName(iStartingTime),'(E11.5)') AvailableDelay(iStartingTime) - IF (DebugLevel.GT.0) WRITE(*,'(A)') StartingTimeName(iStartingTime)//'second' - ENDDO ! loop over starting times + if (DebugLevel > 0) write(*,*) + if (DebugLevel > 0) write(*,'(A)') 'Considering the following exponentially distributed delays:' + do iStartingTime = 0,NStartingTimes + write(StartingTimeName(iStartingTime),'(E11.5)') AvailableDelay(iStartingTime) + if (DebugLevel > 0) write(*,'(A)') StartingTimeName(iStartingTime)//'second' + enddo ! loop over starting times - CALL GetTransitionMatrices(UseICRP) - END SUBROUTINE InitLibPinPoint + call GetTransitionMatrices(UseICRP) + end subroutine InitLibPinPoint - SUBROUTINE ReadRIVMSourceTermFile(FName,MyCocktail) + subroutine ReadRIVMSourceTermFile(FName,MyCocktail) ! ! Read sourceterm with RIVM file format ! - TYPE(CocktailType), INTENT(OUT) :: MyCocktail - CHARACTER(*), INTENT(IN) :: FName + type(CocktailType), intent(out) :: MyCocktail + character(*), intent(in) :: FName - CHARACTER(10) :: MyName - CHARACTER(DefaultLength) :: ALine - INTEGER :: iLine,iNuclide,TheIndex,iCharacter - LOGICAL :: Ready,IsNotABackSlash - REAL(Float) :: MyActivity,ScalingFactor + character(10) :: MyName + character(DefaultLength) :: ALine + integer :: iNuclide,TheIndex,iCharacter + logical :: Ready,IsNotABackSlash + real(Float) :: MyActivity,ScalingFactor - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 ! ! Extract name of the source term from filename ! TheIndex = INDEX(FName,'.RIVMSource') - IF (TheIndex.EQ.0) THEN - WRITE(*,'(A)') 'Sourcterm "'//TRIM(FName)//'" is not of type .RIVMSource! Exiting!!' - CALL EXIT() - ENDIF + if (TheIndex == 0) then + write(*,'(A)') 'Sourcterm "'//trim(FName)//'" is not of type .RIVMSource! Exiting!!' + call exit() + endif ! ! Extract directory ! MyCocktail%MyDirectory = FName - iCharacter = LEN_TRIM(MyCocktail%MyDirectory) - IsNotABackSlash = .NOT.(MyCocktail%MyDirectory(iCharacter:iCharacter).EQ.'/') - DO WHILE (IsNotABackSlash.AND.(iCharacter.GT.0)) + iCharacter = len_trim(MyCocktail%MyDirectory) + IsNotABackSlash = .NOT.(MyCocktail%MyDirectory(iCharacter:iCharacter) == '/') + do while (IsNotABackSlash.AND.(iCharacter > 0)) MyCocktail%MyDirectory(iCharacter:iCharacter) = ' ' iCharacter = iCharacter - 1 - IF (iCharacter.GT.0) IsNotABackSlash = .NOT.(MyCocktail%MyDirectory(iCharacter:iCharacter).EQ.'/') - ENDDO + if (iCharacter > 0) IsNotABackSlash = .NOT.(MyCocktail%MyDirectory(iCharacter:iCharacter) == '/') + enddo ! ! Extract name of sourceterm ! - MyCocktail%MyName = FName((LEN_TRIM(MyCocktail%MyDirectory)+1):(TheIndex-1)) + MyCocktail%MyName = FName((len_trim(MyCocktail%MyDirectory)+1):(TheIndex-1)) ! ! Read file ! MyCocktail%x = 0._Float - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='READ') + open(ScratchFile,file=FName,form='FORMATTED',action='READ') ! ! Read header to find meta-info, e.g. scaling factor for activity ! ScalingFactor = 1._Float Ready = .FALSE. - DO WHILE (.NOT.Ready) - READ(ScratchFile,'(A)') ALine - IF (DebugLevel.GT.1) WRITE(*,'(A)') 'ALine = "'//TRIM(ALine)//'"' + do while (.NOT.Ready) + read(ScratchFile,'(A)') ALine + if (DebugLevel > 1) write(*,'(A)') 'ALine = "'//trim(ALine)//'"' TheIndex = INDEX(ALine,'') - IF (TheIndex.GT.0) THEN - READ(ALine((TheIndex+15):LEN_TRIM(ALine)),*) ScalingFactor - IF (DebugLevel.GT.1) WRITE(*,'(A,EN15.5)') 'Found scaling factor ',ScalingFactor - ENDIF + if (TheIndex > 0) then + read(ALine((TheIndex+15):len_trim(ALine)),*) ScalingFactor + if (DebugLevel > 1) write(*,'(A,EN15.5)') 'Found scaling factor ',ScalingFactor + endif - Ready = (ALine(1:1).NE.'!') - ENDDO + Ready = (ALine(1:1) /= '!') + enddo ! ! Read the nuclide vector and take into account the optional scaling factor ! - WRITE(*,'(A)') 'Reading source term at t=0 from '//TRIM(FName) + write(*,'(A)') 'Reading source term at t=0 from '//trim(FName) Ready = .FALSE. - DO WHILE (.NOT.Ready) - IF (DebugLevel.GT.1) WRITE(*,'(A)') 'ALine = "'//TRIM(ALine)//'"' + do while (.NOT.Ready) + if (DebugLevel > 1) write(*,'(A)') 'ALine = "'//trim(ALine)//'"' - IF (ALine(1:1).NE.'!') THEN - READ(ALine,*) MyName,MyActivity + if (ALine(1:1) /= '!') then + read(ALine,*) MyName,MyActivity - CALL MassNuc2NucMass(MyName) - CALL AllUpCase(MyName) - CALL EnsureHyphen(MyName) + call MassNuc2NucMass(MyName) + call AllUpCase(MyName) + call EnsureHyphen(MyName) iNuclide = GetNuclideNumber(MyName) - IF (iNuclide.EQ.0) THEN - WRITE(*,'(A)') 'Could not recognize nuclide "'//TRIM(MyName)//'"! Exiting!' - CALL EXIT() - ENDIF + if (iNuclide == 0) then + write(*,'(A)') 'Could not recognize nuclide "'//trim(MyName)//'"! Exiting!' + call exit() + endif MyCocktail%x(iNuclide) = ScalingFactor * MyActivity ! [Bq/10kt] - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,A,I4,A,EN20.10,A)') MyName,' = nuclide ',iNuclide,& + if (DebugLevel > 0) then + write(*,'(A,A,I4,A,EN20.10,A)') MyName,' = nuclide ',iNuclide,& & ' and has activity ',MyCocktail%x(iNuclide),' Bq/10kt' - ENDIF - ENDIF ! not a comment line stat starts with ! + endif + endif ! not a comment line stat starts with ! - READ(ScratchFile,'(A)',END=10) ALine + read(ScratchFile,'(A)',end=10) ALine - Ready = (LEN_TRIM(ALine).EQ.0) - ENDDO ! loop until ready + Ready = (len_trim(ALine) == 0) + enddo ! loop until ready - 10 CONTINUE - CLOSE(ScratchFile) - END SUBROUTINE ReadRIVMSourceTermFile + 10 continue + close(ScratchFile) + end subroutine ReadRIVMSourceTermFile - SUBROUTINE GetTransitionMatrices(UseICRP) + subroutine GetTransitionMatrices(UseICRP) ! ! Get transition matrices for all pinpoints ! - LOGICAL, INTENT(IN) :: UseICRP + logical, intent(in) :: UseICRP - CHARACTER(DefaultLength) :: FName,ALine - INTEGER :: iStartingTime,iLine - CHARACTER(6) :: PinPointName + character(DefaultLength) :: FName,ALine + integer :: iStartingTime,iLine + character(6) :: PinPointName - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - WRITE(*,'(A)') 'Getting transition matrices...' - DO iStartingTime = 1,NStartingTimes + write(*,'(A)') 'Getting transition matrices...' + do iStartingTime = 1,NStartingTimes ! ! Open file ! - WRITE(PinPointName,'(I3.3)') iStartingTime - - IF (UseICRP) THEN - FName = 'SparseMatrix_'//TRIM(StartingTimeName(iStartingTime))//'second.dat' - ELSE - FName = 'SparseMatrix_ENDF_'//TRIM(PinPointName)//'.dat' - ENDIF - - IF (DebugLevel.GT.0) WRITE(*,'(A)') 'Reading '//TRIM(FName) - CALL FLUSH(6) - OPEN(ScratchFile, FILE=TransitionMatrixPath() // '/' // TRIM(FName), ACTION='READ') - - IF (.NOT.UseICRP) THEN - DO iLine=1,7 - READ(ScratchFile,*) ! Skip header - ENDDO - ENDIF + write(PinPointName,'(I3.3)') iStartingTime + + if (UseICRP) then + FName = 'SparseMatrix_'//trim(StartingTimeName(iStartingTime))//'second.dat' + else + FName = 'SparseMatrix_ENDF_'//trim(PinPointName)//'.dat' + endif + + if (DebugLevel > 0) write(*,'(A)') 'Reading '//trim(FName) + call FLUSH(6) + open(ScratchFile, file=TransitionMatrixPath() // '/' // trim(FName), action='READ') + + if (.NOT.UseICRP) then + do iLine=1,7 + read(ScratchFile,*) ! Skip header + enddo + endif ! ! Count number of sparse matrix elements to allocate space for ! TransitionMatrix(iStartingTime)%N = 0 - DO - READ(ScratchFile,'(A)',END=10) ALine + do + read(ScratchFile,'(A)',end=10) ALine TransitionMatrix(iStartingTime)%N = TransitionMatrix(iStartingTime)%N + 1 - ENDDO - 10 CONTINUE + enddo + 10 continue - IF (DebugLevel.GT.0) WRITE(*,'(A,I0,A)') TRIM(FName)//' has ',TransitionMatrix(iStartingTime)%N,' elements' + if (DebugLevel > 0) write(*,'(A,I0,A)') trim(FName)//' has ',TransitionMatrix(iStartingTime)%N,' elements' REWIND(ScratchFile) ! ! Rewind file and read matrix elements ! TransitionMatrix(iStartingTime)%NMax = TransitionMatrix(iStartingTime)%N - ALLOCATE(TransitionMatrix(iStartingTime)%Element(TransitionMatrix(iStartingTime)%NMax)) + allocate(TransitionMatrix(iStartingTime)%Element(TransitionMatrix(iStartingTime)%NMax)) TransitionMatrix(iStartingTime)%N = 0 - IF (.NOT.UseICRP) THEN - DO iLine=1,7 - READ(ScratchFile,*) ! Skip header - ENDDO - ENDIF + if (.NOT.UseICRP) then + do iLine=1,7 + read(ScratchFile,*) ! Skip header + enddo + endif - DO - READ(ScratchFile,'(A)',END=20) ALine + do + read(ScratchFile,'(A)',end=20) ALine TransitionMatrix(iStartingTime)%N = TransitionMatrix(iStartingTime)%N + 1 - READ(ALine,*) TransitionMatrix(iStartingTime)%Element(TransitionMatrix(iStartingTime)%N) - ENDDO - 20 CONTINUE - CLOSE(ScratchFile) - ENDDO ! loop over starting times - END SUBROUTINE GetTransitionMatrices + read(ALine,*) TransitionMatrix(iStartingTime)%Element(TransitionMatrix(iStartingTime)%N) + enddo + 20 continue + close(ScratchFile) + enddo ! loop over starting times + end subroutine GetTransitionMatrices - SUBROUTINE SaveCocktail2(Cocktail,Tag) + subroutine SaveCocktail2(Cocktail,Tag) ! ! Save a cocktail of radionuclides to file ! - TYPE(CocktailType), INTENT(IN) :: Cocktail - CHARACTER(*), INTENT(IN) :: Tag + type(CocktailType), intent(in) :: Cocktail + character(*), intent(in) :: Tag - REAL(Float), PARAMETER :: NegligibleActivity = 0._Float ! 10.E9_Float ! Bq/10kt, seems to characterize difference between tables 2 and 5 - CHARACTER(DefaultLength) :: FName - INTEGER :: iNuclide + real(Float), parameter :: NegligibleActivity = 0._Float ! 10.E9_Float ! Bq/10kt, seems to characterize difference between tables 2 and 5 + character(DefaultLength) :: FName + integer :: iNuclide - FName = TRIM(Cocktail%MyName)//'_'//TRIM(Tag)//'.dat' - OPEN(ScratchFile,FILE=TRIM(Cocktail%MyDirectory)//TRIM(FName),ACTION='WRITE') - WRITE(ScratchFile,'(A)') 'Nuclide Activity[Bq]' - DO iNuclide = 1,NNuclides - IF (Cocktail%x(iNuclide).GT.NegligibleActivity) THEN - WRITE(ScratchFile,'(A,1X,EN11.2)') NuclideSpecs(iNuclide)%NuclideName,Cocktail%x(iNuclide) - ENDIF - ENDDO - CLOSE(ScratchFile) - END SUBROUTINE SaveCocktail2 + FName = trim(Cocktail%MyName)//'_'//trim(Tag)//'.dat' + open(ScratchFile,file=trim(Cocktail%MyDirectory)//trim(FName),action='WRITE') + write(ScratchFile,'(A)') 'Nuclide Activity[Bq]' + do iNuclide = 1,NNuclides + if (Cocktail%x(iNuclide) > NegligibleActivity) then + write(ScratchFile,'(A,1X,EN11.2)') NuclideSpecs(iNuclide)%NuclideName,Cocktail%x(iNuclide) + endif + enddo + close(ScratchFile) + end subroutine SaveCocktail2 - SUBROUTINE MatureCocktail(InCocktail,TheMatrix,WithProgeny,OutCocktail) + subroutine MatureCocktail(InCocktail,TheMatrix,WithProgeny,OutCocktail) ! ! Estimate the cocktail at a given delay from the cocktail at t=0 and the transition matrix for the given delay ! - TYPE(CocktailType), INTENT(IN) :: InCocktail - TYPE(SparseMatrix), INTENT(IN) :: TheMatrix - LOGICAL, INTENT(IN) :: WithProgeny - TYPE(CocktailType), INTENT(OUT) :: OutCocktail + type(CocktailType), intent(in) :: InCocktail + type(SparseMatrix), intent(in) :: TheMatrix + logical, intent(in) :: WithProgeny + type(CocktailType), intent(out) :: OutCocktail - INTEGER :: iElement,iMother,iDaughter,iNuclide - REAL(Float) :: x + integer :: iElement,iMother,iDaughter,iNuclide + real(Float) :: x - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 - IF (DebugLevel.GT.0) THEN - DO iNuclide = 1,NNuclides - IF (InCocktail%x(iNuclide).GT.0._Float) THEN - WRITE(*,'(A,A,A,I4,A,EN20.10,A)') 'MatureCocktail: ',& + if (DebugLevel > 0) then + do iNuclide = 1,NNuclides + if (InCocktail%x(iNuclide) > 0._Float) then + write(*,'(A,A,A,I4,A,EN20.10,A)') 'MatureCocktail: ',& & NuclideSpecs(iNuclide)%NuclideName,' = nuclide ',iNuclide,& & ' and has activity ',InCocktail%x(iNuclide),' Bq' - ENDIF - ENDDO - ENDIF ! debug + endif + enddo + endif ! debug OutCocktail%x = 0._Float - OutCocktail%MyName = TRIM(InCocktail%MyName)//'_aged' + OutCocktail%MyName = trim(InCocktail%MyName)//'_aged' OutCocktail%MyDirectory = InCocktail%MyDirectory - DO iElement = 1,TheMatrix%N + do iElement = 1,TheMatrix%N iMother = TheMatrix%Element(iElement)%i iDaughter = TheMatrix%Element(iElement)%j x = TheMatrix%Element(iElement)%x - IF (WithProgeny.OR.(iMother.EQ.iDaughter)) THEN + if (WithProgeny.OR.(iMother == iDaughter)) then - IF ((DebugLevel.GT.0).AND.(InCocktail%x(iMother).GT.0._Float)) THEN - WRITE(*,'(A,A,A,A,A,EN15.5,A,EN15.5,A,EN15.5)') 'Maturization of ',& + if ((DebugLevel > 0).AND.(InCocktail%x(iMother) > 0._Float)) then + write(*,'(A,A,A,A,A,EN15.5,A,EN15.5,A,EN15.5)') 'Maturization of ',& & NuclideSpecs(iDaughter)%NuclideName,& & ' because of initial presence of ',& & NuclideSpecs(iMother)%NuclideName ,& @@ -325,42 +327,42 @@ SUBROUTINE MatureCocktail(InCocktail,TheMatrix,WithProgeny,OutCocktail) & OutCocktail%x(iDaughter),& & ' + ',x*InCocktail%x(iMother),' = ',& & OutCocktail%x(iDaughter) + x*InCocktail%x(iMother) - ENDIF ! debug + endif ! debug OutCocktail%x(iDaughter) = OutCocktail%x(iDaughter) + x*InCocktail%x(iMother) - IF (OutCocktail%x(iDaughter).LT.1.E-95_Float) OutCocktail%x(iDaughter) = 0._Float ! to prevent exponents with 3 digits, which print ugly... - ENDIF - ENDDO ! loop over elements - END SUBROUTINE MatureCocktail + if (OutCocktail%x(iDaughter) < 1.E-95_Float) OutCocktail%x(iDaughter) = 0._Float ! to prevent exponents with 3 digits, which print ugly... + endif + enddo ! loop over elements + end subroutine MatureCocktail - SUBROUTINE MakePinpointDoseRates(MyStartCocktail,WithDaughters,MotherNature,DaughterNature) + subroutine MakePinpointDoseRates(MyStartCocktail,WithDaughters,MotherNature,DaughterNature) ! ! Estimate dose contributions at all pinpoints ! Add dose contribution to the head of chain, assume ground activity to be fully on top = "planar" ! - TYPE(CocktailType), INTENT(IN) :: MyStartCocktail - LOGICAL, INTENT(IN) :: WithDaughters - INTEGER, INTENT(IN) :: MotherNature,DaughterNature ! 0 = any, 1 = noble gas, 2 = not a noble gas + type(CocktailType), intent(in) :: MyStartCocktail + logical, intent(in) :: WithDaughters + integer, intent(in) :: MotherNature,DaughterNature ! 0 = any, 1 = noble gas, 2 = not a noble gas - REAL(Float), DIMENSION(0:NStartingTimes,MaxNuclides) :: PinAirDoseRate,PinGroundDoseRate,& + real(Float), dimension(0:NStartingTimes,MaxNuclides) :: PinAirDoseRate,PinGroundDoseRate,& & PinInhalationDoseRate,PinThyroidInhalationDoseRate - INTEGER, DIMENSION(MaxNuclides) :: ParticipatingNuclide - INTEGER :: NParticipatingNuclides - REAL(Float), DIMENSION(MaxNuclides) :: SumAirDoseRate - INTEGER :: iPinpoint,iNuclide,iDaughter,iMother,iElement,jNuclide,NProgeny - REAL(Float) :: DaughterActivity,x - REAL(Float), DIMENSION(0:NStartingTimes) :: TotalAirDoseRate,TotalGroundDoseRate,TotalImmersionDoseRate,& + integer, dimension(MaxNuclides) :: ParticipatingNuclide + integer :: NParticipatingNuclides + real(Float), dimension(MaxNuclides) :: SumAirDoseRate + integer :: iPinpoint,iNuclide,iDaughter,iMother,iElement,jNuclide,NProgeny + real(Float) :: DaughterActivity,x + real(Float), dimension(0:NStartingTimes) :: TotalAirDoseRate,TotalGroundDoseRate,TotalImmersionDoseRate,& & TotalThyroidDoseRate - CHARACTER(DefaultLength) :: FName,WithDaughterString,NaturesName - LOGICAL :: NaturesOkay,MotherNatureOkay,DaughterNatureOkay + character(DefaultLength) :: FName,WithDaughterString,NaturesName + logical :: NaturesOkay,MotherNatureOkay,DaughterNatureOkay - INTEGER, PARAMETER :: AnyNature = 0 - INTEGER, PARAMETER :: NobleNature = 1 - INTEGER, PARAMETER :: NonNobleNature = 2 + integer, parameter :: AnyNature = 0 + integer, parameter :: NobleNature = 1 + integer, parameter :: NonNobleNature = 2 - INTEGER, PARAMETER :: DebugLevel = 1 + integer, parameter :: DebugLevel = 1 PinAirDoseRate = 0._Float PinGroundDoseRate = 0._Float @@ -368,28 +370,28 @@ SUBROUTINE MakePinpointDoseRates(MyStartCocktail,WithDaughters,MotherNature,Daug PinThyroidInhalationDoseRate = 0._Float SumAirDoseRate = 0._Float - IF (WithDaughters) THEN + if (WithDaughters) then WithDaughterString = 'withprogeny' - ELSE + else WithDaughterString = 'noprogeny' - ENDIF + endif - DO iPinpoint = 0,NStartingTimes + do iPinpoint = 0,NStartingTimes - IF (iPinpoint.EQ.0) THEN + if (iPinpoint == 0) then ! According to pinpoint 0, there is only the head of chain, which is any fission product available at t=0. - DO iNuclide = 1,NNuclides + do iNuclide = 1,NNuclides - MotherNatureOkay = (MotherNature.EQ.AnyNature)& - & .OR.((MotherNature.EQ.NobleNature ).AND.(NuclideSpecs(iNuclide)%NuclideGroup.EQ.1)) & - & .OR.((MotherNature.EQ.NonNobleNature).AND.(NuclideSpecs(iNuclide)%NuclideGroup.NE.1)) - DaughterNatureOkay = (DaughterNature.EQ.AnyNature)& - & .OR.((DaughterNature.EQ.NobleNature ).AND.(NuclideSpecs(iNuclide)%NuclideGroup.EQ.1)) & - & .OR.((DaughterNature.EQ.NonNobleNature).AND.(NuclideSpecs(iNuclide)%NuclideGroup.NE.1)) + MotherNatureOkay = (MotherNature == AnyNature)& + & .OR.((MotherNature == NobleNature ).AND.(NuclideSpecs(iNuclide)%NuclideGroup == 1)) & + & .OR.((MotherNature == NonNobleNature).AND.(NuclideSpecs(iNuclide)%NuclideGroup /= 1)) + DaughterNatureOkay = (DaughterNature == AnyNature)& + & .OR.((DaughterNature == NobleNature ).AND.(NuclideSpecs(iNuclide)%NuclideGroup == 1)) & + & .OR.((DaughterNature == NonNobleNature).AND.(NuclideSpecs(iNuclide)%NuclideGroup /= 1)) NaturesOkay = MotherNatureOkay .AND. DaughterNatureOkay - IF (NaturesOkay) THEN + if (NaturesOkay) then DaughterActivity = MyStartCocktail%x(iNuclide) PinAirDoseRate(iPinpoint,iNuclide) = PinAirDoseRate(iPinpoint,iNuclide) & @@ -417,28 +419,28 @@ SUBROUTINE MakePinpointDoseRates(MyStartCocktail,WithDaughters,MotherNature,Daug & * (1._Float/3600._Float) SumAirDoseRate(iNuclide) = SumAirDoseRate(iNuclide) + PinAirDoseRate(iPinpoint,iNuclide) - ENDIF ! natures okay - ENDDO ! loop over nuclides - ELSE + endif ! natures okay + enddo ! loop over nuclides + else ! ! For any pinpoint > 0, you have the full decay chain with progeny under each head of chain (formed at t=0) ! - DO iElement = 1,TransitionMatrix(iPinpoint)%N + do iElement = 1,TransitionMatrix(iPinpoint)%N iMother = TransitionMatrix(iPinpoint)%Element(iElement)%i iDaughter = TransitionMatrix(iPinpoint)%Element(iElement)%j - MotherNatureOkay = (MotherNature.EQ.AnyNature)& - & .OR.((MotherNature.EQ.NobleNature ).AND.(NuclideSpecs(iMother)%NuclideGroup.EQ.1)) & - & .OR.((MotherNature.EQ.NonNobleNature).AND.(NuclideSpecs(iMother)%NuclideGroup.NE.1)) - DaughterNatureOkay = (DaughterNature.EQ.AnyNature)& - & .OR.((DaughterNature.EQ.NobleNature ).AND.(NuclideSpecs(iDaughter)%NuclideGroup.EQ.1)) & - & .OR.((DaughterNature.EQ.NonNobleNature).AND.(NuclideSpecs(iDaughter)%NuclideGroup.NE.1)) + MotherNatureOkay = (MotherNature == AnyNature)& + & .OR.((MotherNature == NobleNature ).AND.(NuclideSpecs(iMother)%NuclideGroup == 1)) & + & .OR.((MotherNature == NonNobleNature).AND.(NuclideSpecs(iMother)%NuclideGroup /= 1)) + DaughterNatureOkay = (DaughterNature == AnyNature)& + & .OR.((DaughterNature == NobleNature ).AND.(NuclideSpecs(iDaughter)%NuclideGroup == 1)) & + & .OR.((DaughterNature == NonNobleNature).AND.(NuclideSpecs(iDaughter)%NuclideGroup /= 1)) NaturesOkay = MotherNatureOkay .AND. DaughterNatureOkay - IF (NaturesOkay) THEN + if (NaturesOkay) then - IF (WithDaughters.OR.(iMother.EQ.iDaughter)) THEN + if (WithDaughters.OR.(iMother == iDaughter)) then x = TransitionMatrix(iPinpoint)%Element(iElement)%x DaughterActivity = x * MyStartCocktail%x(iMother) @@ -446,12 +448,12 @@ SUBROUTINE MakePinpointDoseRates(MyStartCocktail,WithDaughters,MotherNature,Daug PinAirDoseRate(iPinpoint,iMother) = PinAirDoseRate(iPinpoint,iMother) & & + DaughterActivity & & * DCCEffectiveDose(InAir,Age_Adult)%x(iDaughter) & - & * 1.E-9/3600._Float ! Conversion of nSv/h to Sv/s + & * 1.E-9_Float/3600._Float ! Conversion of nSv/h to Sv/s PinGroundDoseRate(iPinpoint,iMother) = PinGroundDoseRate(iPinpoint,iMother) & & + DaughterActivity & & * DCCGround(1,Age_Adult)%x(iDaughter) & - & * 1.E-9/3600._Float ! Conversion of nSv/h to Sv/s + & * 1.E-9_Float/3600._Float ! Conversion of nSv/h to Sv/s PinInhalationDoseRate(iPinpoint,iMother) = PinInhalationDoseRate(iPinpoint,iMother) & & + DaughterActivity & @@ -464,206 +466,206 @@ SUBROUTINE MakePinpointDoseRates(MyStartCocktail,WithDaughters,MotherNature,Daug & * (1._Float/3600._Float) ! Conversion of Sv/(m3/s) to Sv/(m3/h) to facilitate breathing rates in m3/h SumAirDoseRate(iMother) = SumAirDoseRate(iMother) + PinAirDoseRate(iPinpoint,iMother) - ENDIF ! withdaughters - ENDIF ! natures okay + endif ! withdaughters + endif ! natures okay - ENDDO ! loop over sparse matrix at iLower - ENDIF ! first pinpoint is t=0 + enddo ! loop over sparse matrix at iLower + endif ! first pinpoint is t=0 - ENDDO ! loop over all pinpoints + enddo ! loop over all pinpoints ! ! Cut off values < 0.1E-99, as they are printed in an ugly way... ! - DO iPinpoint = 0,NStartingTimes - DO iNuclide = 1,NNuclides - IF (PinAirDoseRate(iPinpoint,iNuclide).LE.0.1E-99_Float) & + do iPinpoint = 0,NStartingTimes + do iNuclide = 1,NNuclides + if (PinAirDoseRate(iPinpoint,iNuclide) <= 0.1E-99_Float) & & PinAirDoseRate(iPinpoint,iNuclide) = 0._Float - IF (PinGroundDoseRate(iPinpoint,iNuclide).LE.0.1E-99_Float) & + if (PinGroundDoseRate(iPinpoint,iNuclide) <= 0.1E-99_Float) & & PinGroundDoseRate(iPinpoint,iNuclide) = 0._Float - IF (PinInhalationDoseRate(iPinpoint,iNuclide).LE.0.1E-99_Float) & + if (PinInhalationDoseRate(iPinpoint,iNuclide) <= 0.1E-99_Float) & & PinInhalationDoseRate(iPinpoint,iNuclide) = 0._Float - IF (PinThyroidInhalationDoseRate(iPinpoint,iNuclide).LE.0.1E-99_Float) & + if (PinThyroidInhalationDoseRate(iPinpoint,iNuclide) <= 0.1E-99_Float) & & PinThyroidInhalationDoseRate(iPinpoint,iNuclide) = 0._Float - ENDDO ! loop over nuclides - ENDDO ! loop over all pinpoints + enddo ! loop over nuclides + enddo ! loop over all pinpoints ! ! Check which nuclides contribute at all on basis of sum of air doserates. ! Ground and inhalation rates are not considered to give a different answer. ! NParticipatingNuclides = 0 - DO iNuclide = 1,NNuclides - IF (SumAirDoseRate(iNuclide).GT.0._Float) THEN + do iNuclide = 1,NNuclides + if (SumAirDoseRate(iNuclide) > 0._Float) then NParticipatingNuclides = NParticipatingNuclides + 1 ParticipatingNuclide(NParticipatingNuclides) = iNuclide - IF (DebugLevel.GT.0) THEN + if (DebugLevel > 0) then NProgeny = 0 - DO jNuclide = 1,NNuclides - IF ((MotherDaughterMatrix(jNuclide,iNuclide).NE.0._Float).AND.(jNuclide.NE.iNuclide)) THEN + do jNuclide = 1,NNuclides + if ((MotherDaughterMatrix(jNuclide,iNuclide) /= 0._Float).AND.(jNuclide /= iNuclide)) then NProgeny = NProgeny + 1 - ENDIF ! found progeny - ENDDO ! loop over possible progeny of head of chain - IF (NProgeny.EQ.0) THEN - WRITE(*,'(I4,1X,A7,7X,EN15.5,A)') NParticipatingNuclides,NuclideSpecs(iNuclide)%NuclideName,& + endif ! found progeny + enddo ! loop over possible progeny of head of chain + if (NProgeny == 0) then + write(*,'(I4,1X,A7,7X,EN15.5,A)') NParticipatingNuclides,NuclideSpecs(iNuclide)%NuclideName,& & MyStartCocktail%x(iNuclide),' [Bq]' - ELSE - WRITE(*,'(I4,1X,A7,A,EN15.5,A)') NParticipatingNuclides,NuclideSpecs(iNuclide)%NuclideName,' chain:',& + else + write(*,'(I4,1X,A7,A,EN15.5,A)') NParticipatingNuclides,NuclideSpecs(iNuclide)%NuclideName,' chain:',& & MyStartCocktail%x(iNuclide),' [Bq]' - DO jNuclide = 1,NNuclides - IF ((MotherDaughterMatrix(jNuclide,iNuclide).NE.0._Float).AND.(jNuclide.NE.iNuclide)) THEN - WRITE(*,'(11X,A,1X,A7)') '+ progeny',NuclideSpecs(jNuclide)%NuclideName - ENDIF ! found progeny - ENDDO ! loop over possible progeny of head of chain - ENDIF ! progeny found - ENDIF ! participating - ENDIF ! nuclide is participating - ENDDO ! loop over nuclides + do jNuclide = 1,NNuclides + if ((MotherDaughterMatrix(jNuclide,iNuclide) /= 0._Float).AND.(jNuclide /= iNuclide)) then + write(*,'(11X,A,1X,A7)') '+ progeny',NuclideSpecs(jNuclide)%NuclideName + endif ! found progeny + enddo ! loop over possible progeny of head of chain + endif ! progeny found + endif ! participating + endif ! nuclide is participating + enddo ! loop over nuclides ! ! option to Write pinpoint doses to file ! - IF (DebugLevel.GT.0) THEN + if (DebugLevel > 0) then - IF (MotherNature.EQ.AnyNature) THEN + if (MotherNature == AnyNature) then NaturesName = ' ' - ELSE IF (MotherNature.EQ.NobleNature) THEN + else if (MotherNature == NobleNature) then NaturesName = '_MNoble' - ELSE + else NaturesName = '_MNonNoble' - ENDIF + endif - IF (DaughterNature.EQ.AnyNature) THEN - NaturesName = TRIM(NaturesName)//' ' - ELSE IF (DaughterNature.EQ.NobleNature) THEN - NaturesName = TRIM(NaturesName)//'_DNoble' - ELSE - NaturesName = TRIM(NaturesName)//'_DNonNoble' - ENDIF + if (DaughterNature == AnyNature) then + NaturesName = trim(NaturesName)//' ' + else if (DaughterNature == NobleNature) then + NaturesName = trim(NaturesName)//'_DNoble' + else + NaturesName = trim(NaturesName)//'_DNonNoble' + endif TotalAirDoseRate = SUM(PinAirDoseRate,DIM=2) - FName = TRIM(MyStartCocktail%MyDirectory)//TRIM(MyStartCocktail%MyName)//'_PinpointAirDoseRates_'& - & //TRIM(WithDaughterString)//TRIM(NaturesName)//'.txt' + FName = trim(MyStartCocktail%MyDirectory)//trim(MyStartCocktail%MyName)//'_PinpointAirDoseRates_'& + & //trim(WithDaughterString)//trim(NaturesName)//'.txt' - OPEN(ScratchFile,FILE = FName,FORM='FORMATTED',ACTION='WRITE') - WRITE(ScratchFile,'(A)') 'Values are in (Sv/s)*m3. Multiplication with the air thinning '& + open(ScratchFile,file = FName,form='FORMATTED',action='WRITE') + write(ScratchFile,'(A)') 'Values are in (Sv/s)*m3. Multiplication with the air thinning '& & //'factor in /m3 gives the submersion dose rate in Sv/s.' - WRITE(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& + write(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& & 'DelayGrowthFactor:',DelayGrowthFactor,'NStartingTimes:',NStartingTimes - WRITE(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] SumDoseRate ',& + write(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] SumDoseRate ',& & (NuclideSpecs(ParticipatingNuclide(iNuclide))%NuclideName,iNuclide = 1,NParticipatingNuclides) - DO iPinpoint = 0,NStartingTimes - WRITE(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& + do iPinpoint = 0,NStartingTimes + write(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& & TotalAirDoseRate(iPinpoint),& & (PinAirDoseRate(iPinpoint,ParticipatingNuclide(iNuclide)),iNuclide = 1,NParticipatingNuclides) - ENDDO ! loop over nuclides - CLOSE(ScratchFile) + enddo ! loop over nuclides + close(ScratchFile) TotalGroundDoseRate = SUM(PinGroundDoseRate,DIM=2) - FName = TRIM(MyStartCocktail%MyDirectory)//TRIM(MyStartCocktail%MyName)//'_PinpointGroundDoseRates_'& - & //TRIM(WithDaughterString)//TRIM(NaturesName)//'.txt' - OPEN(ScratchFile,FILE = FName,FORM='FORMATTED',ACTION='WRITE') - WRITE(ScratchFile,'(A)') 'Values are in (Sv/s)*m2. Multiplication with the deposition thinning '& + FName = trim(MyStartCocktail%MyDirectory)//trim(MyStartCocktail%MyName)//'_PinpointGroundDoseRates_'& + & //trim(WithDaughterString)//trim(NaturesName)//'.txt' + open(ScratchFile,file = FName,form='FORMATTED',action='WRITE') + write(ScratchFile,'(A)') 'Values are in (Sv/s)*m2. Multiplication with the deposition thinning '& & //'factor in /m2 gives the ground dose rate in Sv/s.' - WRITE(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& + write(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& & 'DelayGrowthFactor:',DelayGrowthFactor,'NStartingTimes:',NStartingTimes - WRITE(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] SumDoseRate ',& + write(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] SumDoseRate ',& & (NuclideSpecs(ParticipatingNuclide(iNuclide))%NuclideName,iNuclide = 1,NParticipatingNuclides) - DO iPinpoint = 0,NStartingTimes - WRITE(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& + do iPinpoint = 0,NStartingTimes + write(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& & TotalGroundDoseRate(iPinpoint),& & (PinGroundDoseRate(iPinpoint,ParticipatingNuclide(iNuclide)),iNuclide = 1,NParticipatingNuclides) - ENDDO ! loop over nuclides - CLOSE(ScratchFile) + enddo ! loop over nuclides + close(ScratchFile) TotalImmersionDoseRate = SUM(PinInhalationDoseRate,DIM=2) - FName = TRIM(MyStartCocktail%MyDirectory)//TRIM(MyStartCocktail%MyName)//'_PinpointInhalationDoseRates_'& - & //TRIM(WithDaughterString)//TRIM(NaturesName)//'.txt' - OPEN(ScratchFile,FILE = FName,FORM='FORMATTED',ACTION='WRITE') - WRITE(ScratchFile,'(A)') 'Values are in Bq * (Sv/Bq) * (h/s). Multiplication with the air thinning '& + FName = trim(MyStartCocktail%MyDirectory)//trim(MyStartCocktail%MyName)//'_PinpointInhalationDoseRates_'& + & //trim(WithDaughterString)//trim(NaturesName)//'.txt' + open(ScratchFile,file = FName,form='FORMATTED',action='WRITE') + write(ScratchFile,'(A)') 'Values are in Bq * (Sv/Bq) * (h/s). Multiplication with the air thinning '& & //'factor in /m3 and the breathing rate in m3/h gives the inhalation dose rate in Sv/s.' - WRITE(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& + write(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& & 'DelayGrowthFactor:',DelayGrowthFactor,'NStartingTimes:',NStartingTimes - WRITE(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] SumDoseRate ',& + write(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] SumDoseRate ',& & (NuclideSpecs(ParticipatingNuclide(iNuclide))%NuclideName,iNuclide = 1,NParticipatingNuclides) - DO iPinpoint = 0,NStartingTimes - WRITE(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& + do iPinpoint = 0,NStartingTimes + write(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& & TotalImmersionDoseRate(iPinpoint),& & (PinInhalationDoseRate(iPinpoint,ParticipatingNuclide(iNuclide)),iNuclide = 1,NParticipatingNuclides) - ENDDO ! loop over nuclides - CLOSE(ScratchFile) + enddo ! loop over nuclides + close(ScratchFile) TotalThyroidDoseRate = SUM(PinThyroidInhalationDoseRate,DIM=2) - FName = TRIM(MyStartCocktail%MyDirectory)//TRIM(MyStartCocktail%MyName)//'_PinpointThyroidInhalationDoseRates_'& - & //TRIM(WithDaughterString)//TRIM(NaturesName)//'.txt' - OPEN(ScratchFile,FILE = FName,FORM='FORMATTED',ACTION='WRITE') - WRITE(ScratchFile,'(A)') 'Values are in Bq * (Sv/Bq) * (h/s). Multiplication with the air thinning '& + FName = trim(MyStartCocktail%MyDirectory)//trim(MyStartCocktail%MyName)//'_PinpointThyroidInhalationDoseRates_'& + & //trim(WithDaughterString)//trim(NaturesName)//'.txt' + open(ScratchFile,file = FName,form='FORMATTED',action='WRITE') + write(ScratchFile,'(A)') 'Values are in Bq * (Sv/Bq) * (h/s). Multiplication with the air thinning '& & //'factor in /m3 and the breathing rate in m3/h gives the inhalation dose rate in Sv/s.' - WRITE(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& + write(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& & 'DelayGrowthFactor:',DelayGrowthFactor,'NStartingTimes:',NStartingTimes - WRITE(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] SumDoseRate ',& + write(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] SumDoseRate ',& & (NuclideSpecs(ParticipatingNuclide(iNuclide))%NuclideName,iNuclide = 1,NParticipatingNuclides) - DO iPinpoint = 0,NStartingTimes - WRITE(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& + do iPinpoint = 0,NStartingTimes + write(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& & TotalThyroidDoseRate(iPinpoint),& & (PinThyroidInhalationDoseRate(iPinpoint,ParticipatingNuclide(iNuclide)),iNuclide = 1,NParticipatingNuclides) - ENDDO ! loop over nuclides - CLOSE(ScratchFile) - ENDIF - END SUBROUTINE MakePinpointDoseRates + enddo ! loop over nuclides + close(ScratchFile) + endif + end subroutine MakePinpointDoseRates - SUBROUTINE GetPinpointCocktails(MyStartCocktail,WithProgeny) + subroutine GetPinpointCocktails(MyStartCocktail,WithProgeny) ! ! Construct the decayed cocktail for all pinpoints ! - TYPE(CocktailType), INTENT(IN) :: MyStartCocktail - LOGICAL, INTENT(IN) :: WithProgeny + type(CocktailType), intent(in) :: MyStartCocktail + logical, intent(in) :: WithProgeny - TYPE(CocktailType), DIMENSION(0:NStartingTimes) :: MyCocktail - CHARACTER(DefaultLength) :: FName,WithDaughterString - INTEGER :: iNuclide,iPinpoint,NParticipatingNuclides - INTEGER, DIMENSION(MaxNuclides) :: ParticipatingNuclide + type(CocktailType), dimension(0:NStartingTimes) :: MyCocktail + character(DefaultLength) :: FName,WithDaughterString + integer :: iNuclide,iPinpoint,NParticipatingNuclides + integer, dimension(MaxNuclides) :: ParticipatingNuclide - IF (WithProgeny) THEN + if (WithProgeny) then WithDaughterString = 'withprogeny' - ELSE + else WithDaughterString = 'noprogeny' - ENDIF + endif ! ! Mature the starting cocktail for all pinpoints ! MyCocktail(0) = MyStartCocktail - DO iPinpoint = 1,NStartingTimes - CALL MatureCocktail(MyStartCocktail,TransitionMatrix(iPinpoint),WithProgeny,MyCocktail(iPinpoint)) - ENDDO ! loop over all pinpoints + do iPinpoint = 1,NStartingTimes + call MatureCocktail(MyStartCocktail,TransitionMatrix(iPinpoint),WithProgeny,MyCocktail(iPinpoint)) + enddo ! loop over all pinpoints ! ! Label the contributing nuclides (to reduce output) ! NParticipatingNuclides = 0 - DO iNuclide = 1,NNuclides - IF (ANY(MyCocktail%x(iNuclide).GT.0._Float)) THEN + do iNuclide = 1,NNuclides + if (ANY(MyCocktail%x(iNuclide) > 0._Float)) then NParticipatingNuclides = NParticipatingNuclides + 1 ParticipatingNuclide(NParticipatingNuclides) = iNuclide - ENDIF ! nuclide is participating - ENDDO ! loop over nuclides + endif ! nuclide is participating + enddo ! loop over nuclides ! ! Write result to file ! - FName = TRIM(MyStartCocktail%MyDirectory)//TRIM(MyStartCocktail%MyName)//'_PinpointCocktail_'& - & //TRIM(WithDaughterString)//'.txt' + FName = trim(MyStartCocktail%MyDirectory)//trim(MyStartCocktail%MyName)//'_PinpointCocktail_'& + & //trim(WithDaughterString)//'.txt' - OPEN(ScratchFile,FILE=FName,FORM='FORMATTED',ACTION='WRITE') + open(ScratchFile,file=FName,form='FORMATTED',action='WRITE') - WRITE(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& + write(ScratchFile,'(A,5X,F10.1,5X,A,F15.5,5X,A,5X,I0)') 'FirstDelay:',FirstDelay,& & 'DelayGrowthFactor:',DelayGrowthFactor,'NStartingTimes:',NStartingTimes - WRITE(ScratchFile,'(I0,A)') NParticipatingNuclides,' = number of nuclides in cocktail' - WRITE(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] ',& + write(ScratchFile,'(I0,A)') NParticipatingNuclides,' = number of nuclides in cocktail' + write(ScratchFile,'(A,2000(A15,1X))') 'Pinpoint t[s] ',& & (NuclideSpecs(ParticipatingNuclide(iNuclide))%NuclideName,iNuclide = 1,NParticipatingNuclides) - DO iPinpoint = 0,NStartingTimes - WRITE(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& + do iPinpoint = 0,NStartingTimes + write(ScratchFile,'(I8,1X,2000(G15.5,1X))') iPinpoint,AvailableDelay(iPinpoint),& & (MyCocktail(iPinpoint)%x(ParticipatingNuclide(iNuclide)),iNuclide = 1,NParticipatingNuclides) - ENDDO ! loop over all pinpoints + enddo ! loop over all pinpoints - CLOSE(ScratchFile) - END SUBROUTINE GetPinpointCocktails -END MODULE Libpinpoint + close(ScratchFile) + end subroutine GetPinpointCocktails +end module Libpinpoint diff --git a/src/lib/libutil.f90 b/src/lib/libutil.f90 index df3e49b..d12bd97 100644 --- a/src/lib/libutil.f90 +++ b/src/lib/libutil.f90 @@ -1,4 +1,4 @@ -MODULE LibUtil +module LibUtil ! ! General purpose utility routines ! @@ -12,12 +12,11 @@ MODULE LibUtil ! The Netherlands ! ____________________________________________________ ! - USE libxmath - IMPLICIT NONE + implicit none - PRIVATE + private public :: env_var - PUBLIC :: RunShellCommand,FileExists,ListModules,PathAndName,MSYSDir,& + public :: RunShellCommand,FileExists,ListModules,PathAndName,MSYSDir,& & UpCase,LowCase,Capitalize,DeCapitalize,CutStringInTwo,& & AllUpCase,AllLowCase,DefaultLength,ScratchFile,ScrotchFile,& & Male,Female,GenderName,RemoveCharacter,CharacterIsADigit @@ -26,45 +25,45 @@ MODULE LibUtil ! etcetera. Only use it if you are SURE that you will close ! it immediatelly! ! - INTEGER, PARAMETER :: ScratchFile = 17 - INTEGER, PARAMETER :: ScrotchFile = 18 + integer, parameter :: ScratchFile = 17 + integer, parameter :: ScrotchFile = 18 ! ! Gender ! - INTEGER, PARAMETER :: Male = 1 - INTEGER, PARAMETER :: Female = 2 + integer, parameter :: Male = 1 + integer, parameter :: Female = 2 - CHARACTER(6), DIMENSION(2), PARAMETER :: GenderName = ((/'male ','female'/)) + character(6), dimension(2), parameter :: GenderName = (['male ','female']) ! ! To accommodate for long file- and directory names, by default such strings ! have the following length: ! - INTEGER, PARAMETER :: DefaultLength = 512 ! With 256 you get problems when wgrib is asked to take action... + integer, parameter :: DefaultLength = 512 ! With 256 you get problems when wgrib is asked to take action... ! ! If you call these sources from MinGW/MSYS, then SYSTEM-calls require the path to MSYS. ! The default path is set here. With a setting in a settings-file the default can be overruled. ! - CHARACTER(DefaultLength) :: MSYSDir = 'c:/MinGW/msys/1.0/bin' + character(DefaultLength) :: MSYSDir = 'c:/MinGW/msys/1.0/bin' !! ! There are always problems with directory/filename combinations: ! Do you have to end the path with a (back-)slash or not? ! To solve this problem, a new datatype is created, plus a routine ! that glues them together. - TYPE PathNameType - CHARACTER(DefaultLength) :: Path,Name - END TYPE PathNameType + type PathNameType + character(DefaultLength) :: Path,Name + end type PathNameType ! ! To discriminate between forward-slash and backslash, you can refer to the following: ! - INTEGER, PARAMETER :: System_Linux = 1 - INTEGER, PARAMETER :: System_Windows = 2 - INTEGER :: TheSystem = System_Linux + integer, parameter :: System_Linux = 1 + integer, parameter :: System_Windows = 2 + integer :: TheSystem = System_Linux ! - ! The following parameter can be set for debugging this MODULE + ! The following parameter can be set for debugging this module ! - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 -CONTAINS +contains subroutine env_var(name, val) character(*), intent(in) :: name character(:), allocatable, intent(out) :: val @@ -89,311 +88,309 @@ subroutine env_var(name, val) endif end subroutine - FUNCTION CharacterIsADigit(Ch) - CHARACTER(1), INTENT(IN) :: Ch - LOGICAL :: CharacterIsADigit - CharacterIsADigit = (INDEX('0123456789',Ch).NE.0) - END FUNCTION CharacterIsADigit + function CharacterIsADigit(Ch) + character(1), intent(in) :: Ch + logical :: CharacterIsADigit + CharacterIsADigit = (INDEX('0123456789',Ch) /= 0) + end function CharacterIsADigit - FUNCTION PathAndName(PathName) + function PathAndName(PathName) ! ! Return a single string resulting from glueing together directory and filename. ! Take a very close look at the slash between them! ! - TYPE(PathNameType), INTENT(IN) :: PathName + type(PathNameType), intent(in) :: PathName - INTEGER :: TheEnd - CHARACTER(DefaultLength) :: PathAndName + integer :: TheEnd + character(DefaultLength) :: PathAndName - TheEnd = LEN_TRIM(PathName%Path) - IF (PathName%Path(TheEnd:TheEnd).EQ.'/') THEN - PathAndName = TRIM(PathName%Path)//TRIM(PathName%Name) - ELSE - PathAndName = TRIM(PathName%Path)//'/'//TRIM(PathName%Name) - ENDIF - END FUNCTION PathAndName + TheEnd = len_trim(PathName%Path) + if (PathName%Path(TheEnd:TheEnd) == '/') then + PathAndName = trim(PathName%Path)//trim(PathName%Name) + else + PathAndName = trim(PathName%Path)//'/'//trim(PathName%Name) + endif + end function PathAndName - SUBROUTINE RunShellCommand(Commando,CrashOnError,DoSilent) + subroutine RunShellCommand(Commando,CrashOnError,DoSilent) ! ! Perform an external shell-command and if necessary halt on error ! - CHARACTER(*), INTENT(IN) :: Commando - INTEGER :: Error,SYSTEM !,ThePlace - LOGICAL, INTENT(IN) :: CrashOnError,DoSilent - CHARACTER(DefaultLength) :: ReversedCommand - - INTEGER, PARAMETER :: DebugLevel = 0 + character(*), intent(in) :: Commando + integer :: Error,SYSTEM !,ThePlace + logical, intent(in) :: CrashOnError,DoSilent + character(DefaultLength) :: ReversedCommand ! ! Make a copy ! - ReversedCommand = TRIM(MSYSDir)//'/'//TRIM(Commando) + ReversedCommand = trim(MSYSDir)//'/'//trim(Commando) ! ! Try the command ! - IF (TheSystem.EQ.System_Windows) THEN - IF (.NOT.DoSilent) WRITE(*,10) TRIM(ReversedCommand) - Error = SYSTEM(TRIM(ReversedCommand)) - ELSE - IF (.NOT.DoSilent) WRITE(*,10) TRIM(Commando) - Error = SYSTEM(TRIM(Commando)) - ENDIF - 10 FORMAT('RunShellCommand : "',A,'"') + if (TheSystem == System_Windows) then + if (.NOT.DoSilent) write(*,10) trim(ReversedCommand) + Error = SYSTEM(trim(ReversedCommand)) + else + if (.NOT.DoSilent) write(*,10) trim(Commando) + Error = SYSTEM(trim(Commando)) + endif + 10 format('RunShellCommand : "',A,'"') ! ! If failure, try with reversed slashes ! - IF (Error.NE.0) THEN - IF (.NOT.DoSilent) WRITE(*,'(A)') 'Failure in shell-command. Retrying with path c:/msys/1.0/bin/ prepended...' + if (Error /= 0) then + if (.NOT.DoSilent) write(*,'(A)') 'Failure in shell-command. Retrying with path c:/msys/1.0/bin/ prepended...' - IF (TheSystem.EQ.System_Windows) THEN - IF (.NOT.DoSilent) WRITE(*,10) TRIM(Commando) - Error = SYSTEM(TRIM(Commando)) - IF (Error.EQ.0) THEN + if (TheSystem == System_Windows) then + if (.NOT.DoSilent) write(*,10) trim(Commando) + Error = SYSTEM(trim(Commando)) + if (Error == 0) then TheSystem = System_Linux ! Switch system mode to Linux - WRITE(*,*) - WRITE(*,'(A)') '--> System reacts better to original way of calling: changing to Linux-mode!' - WRITE(*,*) - ENDIF - ELSE - IF (.NOT.DoSilent) WRITE(*,10) TRIM(ReversedCommand) - Error = SYSTEM(TRIM(ReversedCommand)) - IF (Error.EQ.0) THEN + write(*,*) + write(*,'(A)') '--> System reacts better to original way of calling: changing to Linux-mode!' + write(*,*) + endif + else + if (.NOT.DoSilent) write(*,10) trim(ReversedCommand) + Error = SYSTEM(trim(ReversedCommand)) + if (Error == 0) then TheSystem = System_Windows ! Switch system mode to Windows - WRITE(*,*) - WRITE(*,'(A)') '--> System reacts better to MSYS-specific calling; changing to Windows-mode!' - WRITE(*,*) - ENDIF - ENDIF - - IF (Error.NE.0) THEN - IF (.NOT.DoSilent) WRITE(*,*) '... sorry, second attempt of shell-command failed either!' - IF (.NOT.DoSilent) WRITE(*,20) Error - 20 FORMAT('Error ',I7,' in execution of command') - IF (CrashOnError) STOP - ENDIF - ENDIF + write(*,*) + write(*,'(A)') '--> System reacts better to MSYS-specific calling; changing to Windows-mode!' + write(*,*) + endif + endif + + if (Error /= 0) then + if (.NOT.DoSilent) write(*,*) '... sorry, second attempt of shell-command failed either!' + if (.NOT.DoSilent) write(*,20) Error + 20 format('Error ',I7,' in execution of command') + if (CrashOnError) stop + endif + endif - IF ((Error.EQ.0).AND.(.NOT.DoSilent)) WRITE(*,30) - 30 FORMAT('Shell-command succeeded!') + if ((Error == 0).AND.(.NOT.DoSilent)) write(*,30) + 30 format('Shell-command succeeded!') - END SUBROUTINE RunShellCommand + end subroutine RunShellCommand - FUNCTION FileExists(InName) + function FileExists(InName) ! ! Check if a certain file exists ! - LOGICAL ThisFileExists,FileExists - CHARACTER(*), INTENT(IN) :: InName - INQUIRE(FILE=TRIM(InName),EXIST=ThisFileExists) + logical ThisFileExists,FileExists + character(*), intent(in) :: InName + inquire(file=trim(InName),exist=ThisFileExists) FileExists = ThisFileExists - END FUNCTION FileExists + end function FileExists - FUNCTION PathNameExists(PathName) + function PathNameExists(PathName) ! ! Check if a certain file in a given directory exists ! - LOGICAL ThisPathNameExists,PathNameExists - TYPE(PathNameType), INTENT(IN) :: PathName - INQUIRE(FILE=TRIM(PathAndName(PathName)),EXIST=ThisPathNameExists) + logical ThisPathNameExists,PathNameExists + type(PathNameType), intent(in) :: PathName + inquire(file=trim(PathAndName(PathName)),exist=ThisPathNameExists) PathNameExists = ThisPathNameExists - END FUNCTION PathNameExists + end function PathNameExists - SUBROUTINE RemoveCharacter(MyString,MyCharacter) + subroutine RemoveCharacter(MyString,MyCharacter) ! ! Remove 1 character completely from a string ! - CHARACTER(*), INTENT(INOUT) :: MyString - CHARACTER, INTENT(IN) :: MyCharacter - INTEGER :: MyCharacterPos + character(*), intent(inout) :: MyString + character, intent(in) :: MyCharacter + integer :: MyCharacterPos MyCharacterPos = INDEX(MyString,MyCharacter) - DO WHILE ((MyCharacterPos.GT.0).AND.(MyCharacterPos.LE.LEN_TRIM(MyString))) - MyString = MyString(1:(MyCharacterPos-1))//MyString((MyCharacterPos+1):LEN_TRIM(MyString)) + do while ((MyCharacterPos > 0).AND.(MyCharacterPos <= len_trim(MyString))) + MyString = MyString(1:(MyCharacterPos-1))//MyString((MyCharacterPos+1):len_trim(MyString)) MyCharacterPos = INDEX(MyString,MyCharacter) - ENDDO - END SUBROUTINE RemoveCharacter + enddo + end subroutine RemoveCharacter - SUBROUTINE CutStringInTwo(StringIn,String1,String2,NoSecondString) + subroutine CutStringInTwo(StringIn,String1,String2,NoSecondString) ! ! Cut a string in two pieces. The first part is the first non-trivial ! substring until either a space or a tab character ! - CHARACTER(*), INTENT(INOUT) :: StringIn - CHARACTER(*), INTENT(OUT) :: String1,String2 - LOGICAL, INTENT(OUT) :: NoSecondString + character(*), intent(inout) :: StringIn + character(*), intent(out) :: String1,String2 + logical, intent(out) :: NoSecondString ! ! Local variables ! - INTEGER :: SpacePosition,TabPosition,CutPosition - CHARACTER(500) :: DumStr1,DumStr2 + integer :: SpacePosition,TabPosition,CutPosition + character(500) :: DumStr1,DumStr2 ! ! Remove leading spaces or tabs ! - IF (DebugLevel.GT.0) WRITE(*,10) '"'//TRIM(StringIn)//'"' - 10 FORMAT('Cut : StringIn = ',A) + if (DebugLevel > 0) write(*,10) '"'//trim(StringIn)//'"' + 10 format('Cut : StringIn = ',A) DumStr1 = StringIn - DO WHILE (((DumStr1(1:1).EQ.CHAR(32)).OR.(DumStr1(1:1).EQ.CHAR(9))).AND.(LEN_TRIM(DumStr1).GT.1)) - DumStr1 = DumStr1(2:LEN_TRIM(DumStr1)) - ENDDO - IF (DebugLevel.GT.0) WRITE(*,11) TRIM(DumStr1) - 11 FORMAT(' Cut : DumStr1 zonder spaties aan het begin = "',A,'"') + do while (((DumStr1(1:1) == CHAR(32)).OR.(DumStr1(1:1) == CHAR(9))).AND.(len_trim(DumStr1) > 1)) + DumStr1 = DumStr1(2:len_trim(DumStr1)) + enddo + if (DebugLevel > 0) write(*,11) trim(DumStr1) + 11 format(' Cut : DumStr1 zonder spaties aan het begin = "',A,'"') ! ! Remove trailing tabs ! - DO WHILE ((DumStr1(LEN_TRIM(DumStr1):LEN_TRIM(DumStr1)).EQ.CHAR(9)).AND.(LEN_TRIM(DumStr1).GT.1)) - DumStr1 = DumStr1(1:(LEN_TRIM(DumStr1)-1)) - ENDDO - IF (DebugLevel.GT.0) WRITE(*,12) TRIM(DumStr1) - 12 FORMAT(' Cut : DumStr1 zonder spaties aan het eind = "',A,'"') + do while ((DumStr1(len_trim(DumStr1):len_trim(DumStr1)) == CHAR(9)).AND.(len_trim(DumStr1) > 1)) + DumStr1 = DumStr1(1:(len_trim(DumStr1)-1)) + enddo + if (DebugLevel > 0) write(*,12) trim(DumStr1) + 12 format(' Cut : DumStr1 zonder spaties aan het eind = "',A,'"') ! ! Find a separator: space or tab ! SpacePosition = INDEX(DumStr1,CHAR(32)) TabPosition = INDEX(DumStr1,CHAR(9)) CutPosition = SpacePosition - IF ((TabPosition.GT.0).AND.(TabPosition.LT.SpacePosition)) CutPosition = TabPosition + if ((TabPosition > 0).AND.(TabPosition < SpacePosition)) CutPosition = TabPosition - NoSecondString = ((CutPosition.EQ.0).OR.(CutPosition.EQ.(LEN_TRIM(DumStr1)+1))) + NoSecondString = ((CutPosition == 0).OR.(CutPosition == (len_trim(DumStr1)+1))) - IF (DebugLevel.GT.0) WRITE(*,20) TRIM(DumStr1),SpacePosition,TabPosition,CutPosition - 20 FORMAT(' "',A,'" heeft spatie op ',I3,' en tab op ',I3,' dus we gaan knippen op ',I3) - IF (.NOT.NoSecondString) THEN - DumStr2 = DumStr1((CutPosition+1):LEN_TRIM(DumStr1)) + if (DebugLevel > 0) write(*,20) trim(DumStr1),SpacePosition,TabPosition,CutPosition + 20 format(' "',A,'" heeft spatie op ',I3,' en tab op ',I3,' dus we gaan knippen op ',I3) + if (.NOT.NoSecondString) then + DumStr2 = DumStr1((CutPosition+1):len_trim(DumStr1)) DumStr1 = DumStr1(1:(CutPosition-1)) - ENDIF - IF (DebugLevel.GT.0) THEN - IF (NoSecondString) THEN - WRITE(*,31) TRIM(DumStr1) - 31 FORMAT(' Aan het eind: "',A,'" en verder niets!') - ELSE - WRITE(*,30) TRIM(DumStr1),TRIM(DumStr2) - 30 FORMAT(' Aan het eind: "',A,'" en "',A,'"') - ENDIF - ENDIF - String1 = TRIM(DumStr1) - IF (.NOT.NoSecondString) String2 = TRIM(DumStr2) - IF (DebugLevel.GT.0) WRITE(*,*) - END SUBROUTINE CutStringInTwo + endif + if (DebugLevel > 0) then + if (NoSecondString) then + write(*,31) trim(DumStr1) + 31 format(' Aan het eind: "',A,'" en verder niets!') + else + write(*,30) trim(DumStr1),trim(DumStr2) + 30 format(' Aan het eind: "',A,'" en "',A,'"') + endif + endif + String1 = trim(DumStr1) + if (.NOT.NoSecondString) String2 = trim(DumStr2) + if (DebugLevel > 0) write(*,*) + end subroutine CutStringInTwo - CHARACTER FUNCTION UpCase(Ch) + character function UpCase(Ch) ! ! Make a letter upper case ! - CHARACTER, INTENT(IN) :: Ch - CHARACTER :: DumChar - IF ((ICHAR(Ch).GE.97).AND.(ICHAR(Ch).LE.122)) THEN + character, intent(in) :: Ch + character :: DumChar + if ((ICHAR(Ch) >= 97).AND.(ICHAR(Ch) <= 122)) then DumChar = CHAR(ICHAR(Ch)-32) - ELSE + else DumChar = Ch - ENDIF + endif UpCase = DumChar - END FUNCTION UpCase + end function UpCase - CHARACTER FUNCTION LowCase(Ch) + character function LowCase(Ch) ! ! Make a letter lower case ! - CHARACTER, INTENT(IN) :: Ch - CHARACTER :: DumChar - IF ((ICHAR(Ch).GE.65).AND.(ICHAR(Ch).LE.90)) THEN + character, intent(in) :: Ch + character :: DumChar + if ((ICHAR(Ch) >= 65).AND.(ICHAR(Ch) <= 90)) then DumChar = CHAR(ICHAR(Ch)+32) - ELSE + else DumChar = Ch - ENDIF + endif LowCase = DumChar - END FUNCTION LowCase + end function LowCase - SUBROUTINE AllUpCase(String) + subroutine AllUpCase(String) ! ! Set all letters to capital ! - CHARACTER(*), INTENT(INOUT) :: String - INTEGER :: i,StringLength - StringLength = LEN_TRIM(String) - DO i=1,StringLength + character(*), intent(inout) :: String + integer :: i,StringLength + StringLength = len_trim(String) + do i=1,StringLength String(i:i) = UpCase(String(i:i)) - ENDDO - END SUBROUTINE AllUpCase + enddo + end subroutine AllUpCase - SUBROUTINE AllLowCase(String) + subroutine AllLowCase(String) ! ! Set all letters to lower case ! - CHARACTER(*), INTENT(INOUT) :: String - INTEGER :: i,StringLength - StringLength = LEN_TRIM(String) - DO i=1,StringLength + character(*), intent(inout) :: String + integer :: i,StringLength + StringLength = len_trim(String) + do i=1,StringLength String(i:i) = LowCase(String(i:i)) - ENDDO - END SUBROUTINE AllLowCase + enddo + end subroutine AllLowCase - SUBROUTINE Capitalize(String) + subroutine Capitalize(String) ! ! Set first letter to capital, rest to lower case ! - CHARACTER(*), INTENT(INOUT) :: String - INTEGER :: i,StringLength - StringLength = LEN_TRIM(String) + character(*), intent(inout) :: String + integer :: i,StringLength + StringLength = len_trim(String) String(1:1) = UpCase(String(1:1)) - DO i=2,StringLength + do i=2,StringLength String(i:i) = LowCase(String(i:i)) - ENDDO - END SUBROUTINE Capitalize + enddo + end subroutine Capitalize - SUBROUTINE DeCapitalize(String) + subroutine DeCapitalize(String) ! ! Set all letters to lower case ! - CHARACTER(*), INTENT(INOUT) :: String - INTEGER :: i,StringLength - StringLength = LEN_TRIM(String) - DO i=1,StringLength + character(*), intent(inout) :: String + integer :: i,StringLength + StringLength = len_trim(String) + do i=1,StringLength String(i:i) = LowCase(String(i:i)) - ENDDO - END SUBROUTINE DeCapitalize + enddo + end subroutine DeCapitalize - FUNCTION ListModules(SourceFileName) + function ListModules(SourceFileName) ! ! Make a list of the modulenames used in a sourcefile ! - CHARACTER(*), INTENT(IN) :: SourceFileName - CHARACTER(DefaultLength) :: Commando - LOGICAL, PARAMETER :: CrashOnError = .FALSE., DoSilent = .TRUE. - LOGICAL :: ListModules,Okay + character(*), intent(in) :: SourceFileName + character(DefaultLength) :: Commando + logical, parameter :: CrashOnError = .FALSE., DoSilent = .TRUE. + logical :: ListModules,Okay ! ! Make a list of the MODULES used by the sourcefile ! Okay = FileExists(SourceFileName) - IF (Okay) THEN - Commando = 'grep -i -w use '//TRIM(SourceFileName)//' > listmodules.tmp' - CALL RunShellCommand(Commando,CrashOnError,DoSilent) - ENDIF + if (Okay) then + Commando = 'grep -i -w use '//trim(SourceFileName)//' > listmodules.tmp' + call RunShellCommand(Commando,CrashOnError,DoSilent) + endif ListModules = Okay - END FUNCTION ListModules -END MODULE LibUtil + end function ListModules +end module LibUtil diff --git a/src/lib/libxmath.f90 b/src/lib/libxmath.f90 index 7153db3..5073e1e 100644 --- a/src/lib/libxmath.f90 +++ b/src/lib/libxmath.f90 @@ -1,4 +1,4 @@ -MODULE LibXMath +module LibXMath ! ! Extended mathematics ! @@ -15,412 +15,412 @@ MODULE LibXMath ! ! ____________________________________________________ ! - IMPLICIT NONE + implicit none - PRIVATE + private - PUBLIC :: Float, Vector2, Inc,Vector,dp,& + public :: Float, Vector2, Inc,Vector,dp,& & OPERATOR(*), OPERATOR(/), OPERATOR(+), OPERATOR(-),& & SparseMatrix,SparseMatrixElement,Matrix2SparseMatrix,SparseMatrix2Matrix,& & SparseLogicalMatrixElement,SparseLogicalMatrix,LMatrix2SparseLMatrix,SparseLMatrix2LMatrix ! ! From now on only use "REAL(float)" for reals ! - ! The number of bytes associated with 6 digits precision, usually stored in 4 bytes, default REAL + ! The number of bytes associated with 6 digits precision, usually stored in 4 bytes, default real ! - INTEGER,PARAMETER :: Float = SELECTED_REAL_KIND(12, 60) + integer,parameter :: Float = selected_real_kind(12, 60) ! ! The number of bytes associated with 15 digits precision, usually stored in 8 bytes, default DOUBLE PRECISION ! - INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) + integer, parameter :: dp = selected_real_kind(12, 60) ! ! 2D problems can use the following type: ! - TYPE Vector2 - REAL(Float) :: x(2) - END TYPE Vector2 - - TYPE Vector - REAL(Float) :: x(3) - END TYPE Vector - - INTERFACE OPERATOR (*) - MODULE PROCEDURE MultiplyFloatVector2 - MODULE PROCEDURE MultiplyFloatVector - MODULE PROCEDURE MultiplyVector2Float - MODULE PROCEDURE MultiplyVectorFloat - MODULE PROCEDURE MultiplyVector2Vector2 - MODULE PROCEDURE MultiplyVectorVector - END INTERFACE - - INTERFACE OPERATOR (/) - MODULE PROCEDURE DivideVector2Float - MODULE PROCEDURE DivideVectorFloat - MODULE PROCEDURE DivideVector2Vector2 - MODULE PROCEDURE DivideVectorVector - END INTERFACE - - INTERFACE OPERATOR (+) - MODULE PROCEDURE AddVector2Vector2 - MODULE PROCEDURE AddVectorVector - END INTERFACE - - INTERFACE OPERATOR (-) - MODULE PROCEDURE SubtractVector2Vector2 - MODULE PROCEDURE SubtractVectorVector - END INTERFACE - - TYPE SparseMatrixElement - INTEGER :: i,j - REAL(Float) :: x - END TYPE SparseMatrixElement - - TYPE SparseMatrix - INTEGER :: N,NMax ! N is the number of elements, NMax >=N can be used to allocate on beforehand - TYPE(SparseMatrixElement), ALLOCATABLE, DIMENSION(:) :: Element - END TYPE SparseMatrix - - TYPE SparseLogicalMatrixElement - INTEGER :: i,j - END TYPE SparseLogicalMatrixElement - - TYPE SparseLogicalMatrix - INTEGER :: N,NMax ! N is the number of elements, NMax >=N can be used to allocate on beforehand - TYPE(SparseLogicalMatrixElement), ALLOCATABLE, DIMENSION(:) :: Element - END TYPE SparseLogicalMatrix + type Vector2 + real(Float) :: x(2) + end type Vector2 + + type Vector + real(Float) :: x(3) + end type Vector + + interface OPERATOR (*) + module PROCEDURE MultiplyFloatVector2 + module PROCEDURE MultiplyFloatVector + module PROCEDURE MultiplyVector2Float + module PROCEDURE MultiplyVectorFloat + module PROCEDURE MultiplyVector2Vector2 + module PROCEDURE MultiplyVectorVector + end interface + + interface OPERATOR (/) + module PROCEDURE DivideVector2Float + module PROCEDURE DivideVectorFloat + module PROCEDURE DivideVector2Vector2 + module PROCEDURE DivideVectorVector + end interface + + interface OPERATOR (+) + module PROCEDURE AddVector2Vector2 + module PROCEDURE AddVectorVector + end interface + + interface OPERATOR (-) + module PROCEDURE SubtractVector2Vector2 + module PROCEDURE SubtractVectorVector + end interface + + type SparseMatrixElement + integer :: i,j + real(Float) :: x + end type SparseMatrixElement + + type SparseMatrix + integer :: N,NMax ! N is the number of elements, NMax >=N can be used to allocate on beforehand + type(SparseMatrixElement), allocatable, dimension(:) :: Element + end type SparseMatrix + + type SparseLogicalMatrixElement + integer :: i,j + end type SparseLogicalMatrixElement + + type SparseLogicalMatrix + integer :: N,NMax ! N is the number of elements, NMax >=N can be used to allocate on beforehand + type(SparseLogicalMatrixElement), allocatable, dimension(:) :: Element + end type SparseLogicalMatrix ! - ! The following parameter can be set for debugging this MODULE + ! The following parameter can be set for debugging this module ! - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 ! ! Below this line you'll get the real implementations ! -CONTAINS - FUNCTION MultiplyFloatVector2( xFloat, xVector2 ) +contains + function MultiplyFloatVector2( xFloat, xVector2 ) ! - ! Multiply a REAL(Float) with a Vector2 + ! Multiply a real(Float) with a Vector2 ! - TYPE( Vector2 ) MultiplyFloatVector2, DumVec2 - TYPE( Vector2 ), INTENT( IN ) :: xVector2 - REAL( Float ), INTENT( IN ) :: xFloat + type( Vector2 ) MultiplyFloatVector2, DumVec2 + type( Vector2 ), intent( in ) :: xVector2 + real( Float ), intent( in ) :: xFloat - DumVec2 = Vector2((/xFloat*xVector2%x(1),xFloat*xVector2%x(2)/)) + DumVec2 = Vector2([xFloat*xVector2%x(1),xFloat*xVector2%x(2)]) MultiplyFloatVector2 = DumVec2 - END FUNCTION MultiplyFloatVector2 + end function MultiplyFloatVector2 - FUNCTION MultiplyFloatVector( xFloat, xVector ) + function MultiplyFloatVector( xFloat, xVector ) ! - ! Multiply a REAL(Float) with a Vector + ! Multiply a real(Float) with a Vector ! - TYPE( Vector ) MultiplyFloatVector, DumVec - TYPE( Vector ), INTENT( IN ) :: xVector - REAL( Float ), INTENT( IN ) :: xFloat + type( Vector ) MultiplyFloatVector, DumVec + type( Vector ), intent( in ) :: xVector + real( Float ), intent( in ) :: xFloat - DumVec = Vector((/xFloat*xVector%x(1),xFloat*xVector%x(2),xFloat*xVector%x(3)/)) + DumVec = Vector([xFloat*xVector%x(1),xFloat*xVector%x(2),xFloat*xVector%x(3)]) MultiplyFloatVector = DumVec - END FUNCTION MultiplyFloatVector + end function MultiplyFloatVector - FUNCTION MultiplyVector2Float( xVector2,xFloat ) + function MultiplyVector2Float( xVector2,xFloat ) ! - ! Multiply a Vector2 with a REAL(Float) + ! Multiply a Vector2 with a real(Float) ! - TYPE( Vector2 ) MultiplyVector2Float - TYPE( Vector2 ), INTENT( IN ) :: xVector2 - REAL( Float ), INTENT( IN ) :: xFloat + type( Vector2 ) MultiplyVector2Float + type( Vector2 ), intent( in ) :: xVector2 + real( Float ), intent( in ) :: xFloat MultiplyVector2Float = xFloat*xVector2 - END FUNCTION MultiplyVector2Float + end function MultiplyVector2Float - FUNCTION MultiplyVectorFloat( xVector,xFloat ) + function MultiplyVectorFloat( xVector,xFloat ) ! - ! Multiply a Vector with a REAL(Float) + ! Multiply a Vector with a real(Float) ! - TYPE( Vector ) MultiplyVectorFloat - TYPE( Vector ), INTENT( IN ) :: xVector - REAL( Float ), INTENT( IN ) :: xFloat + type( Vector ) MultiplyVectorFloat + type( Vector ), intent( in ) :: xVector + real( Float ), intent( in ) :: xFloat MultiplyVectorFloat = xFloat*xVector - END FUNCTION MultiplyVectorFloat + end function MultiplyVectorFloat - FUNCTION DivideVector2Float( xVector2,xFloat ) + function DivideVector2Float( xVector2,xFloat ) ! - ! Divide a Vector2 by a REAL(Float) + ! Divide a Vector2 by a real(Float) ! - TYPE( Vector2 ) DivideVector2Float - TYPE( Vector2 ), INTENT( IN ) :: xVector2 - REAL( Float ), INTENT( IN ) :: xFloat + type( Vector2 ) DivideVector2Float + type( Vector2 ), intent( in ) :: xVector2 + real( Float ), intent( in ) :: xFloat - DivideVector2Float = xVector2*(1./xFloat) - END FUNCTION DivideVector2Float + DivideVector2Float = xVector2*(1._Float/xFloat) + end function DivideVector2Float - FUNCTION DivideVectorFloat( xVector,xFloat ) + function DivideVectorFloat( xVector,xFloat ) ! - ! Divide a Vector by a REAL(Float) + ! Divide a Vector by a real(Float) ! - TYPE( Vector ) DivideVectorFloat - TYPE( Vector ), INTENT( IN ) :: xVector - REAL( Float ), INTENT( IN ) :: xFloat + type( Vector ) DivideVectorFloat + type( Vector ), intent( in ) :: xVector + real( Float ), intent( in ) :: xFloat - DivideVectorFloat = xVector*(1./xFloat) - END FUNCTION DivideVectorFloat + DivideVectorFloat = xVector*(1._Float/xFloat) + end function DivideVectorFloat - FUNCTION MultiplyVector2Vector2( xVector2, yVector2 ) + function MultiplyVector2Vector2( xVector2, yVector2 ) ! ! Multiply two Vector2 type of variables ! - TYPE( Vector2 ) MultiplyVector2Vector2, DumVec2 - TYPE( Vector2 ), INTENT( IN ) :: xVector2,yVector2 + type( Vector2 ) MultiplyVector2Vector2, DumVec2 + type( Vector2 ), intent( in ) :: xVector2,yVector2 - DumVec2 = Vector2((/xVector2%x(1)*yVector2%x(1),xVector2%x(2)*yVector2%x(2)/)) + DumVec2 = Vector2([xVector2%x(1)*yVector2%x(1),xVector2%x(2)*yVector2%x(2)]) MultiplyVector2Vector2 = DumVec2 - END FUNCTION MultiplyVector2Vector2 + end function MultiplyVector2Vector2 - FUNCTION DivideVector2Vector2( xVector2, yVector2 ) + function DivideVector2Vector2( xVector2, yVector2 ) ! ! Divide two Vector2 type of variables ! - TYPE( Vector2 ) DivideVector2Vector2, DumVec2 - TYPE( Vector2 ), INTENT( IN ) :: xVector2,yVector2 + type( Vector2 ) DivideVector2Vector2, DumVec2 + type( Vector2 ), intent( in ) :: xVector2,yVector2 - DumVec2 = Vector2((/xVector2%x(1)/yVector2%x(1),xVector2%x(2)/yVector2%x(2)/)) + DumVec2 = Vector2([xVector2%x(1)/yVector2%x(1),xVector2%x(2)/yVector2%x(2)]) DivideVector2Vector2 = DumVec2 - END FUNCTION DivideVector2Vector2 + end function DivideVector2Vector2 - FUNCTION DivideVectorVector( xVector, yVector ) + function DivideVectorVector( xVector, yVector ) ! ! Divide two Vector type of variables ! - TYPE( Vector ) DivideVectorVector, DumVec - TYPE( Vector ), INTENT( IN ) :: xVector,yVector + type( Vector ) DivideVectorVector, DumVec + type( Vector ), intent( in ) :: xVector,yVector - DumVec = Vector((/xVector%x(1)/yVector%x(1),xVector%x(2)/yVector%x(2),xVector%x(3)/yVector%x(3)/)) + DumVec = Vector([xVector%x(1)/yVector%x(1),xVector%x(2)/yVector%x(2),xVector%x(3)/yVector%x(3)]) DivideVectorVector = DumVec - END FUNCTION DivideVectorVector + end function DivideVectorVector - FUNCTION MultiplyVectorVector( xVector, yVector ) + function MultiplyVectorVector( xVector, yVector ) ! ! Multiply two Vector type of variables ! - TYPE( Vector ) MultiplyVectorVector, DumVec - TYPE( Vector ), INTENT( IN ) :: xVector,yVector + type( Vector ) MultiplyVectorVector, DumVec + type( Vector ), intent( in ) :: xVector,yVector - DumVec = Vector((/xVector%x(1)*yVector%x(1),xVector%x(2)*yVector%x(2),xVector%x(3)*yVector%x(3)/)) + DumVec = Vector([xVector%x(1)*yVector%x(1),xVector%x(2)*yVector%x(2),xVector%x(3)*yVector%x(3)]) MultiplyVectorVector = DumVec - END FUNCTION MultiplyVectorVector + end function MultiplyVectorVector - FUNCTION AddVector2Vector2( xVector2, yVector2 ) + function AddVector2Vector2( xVector2, yVector2 ) ! ! Add two Vector2 type of variables ! - TYPE( Vector2 ) AddVector2Vector2, DumVec2 - TYPE( Vector2 ), INTENT( IN ) :: xVector2,yVector2 + type( Vector2 ) AddVector2Vector2, DumVec2 + type( Vector2 ), intent( in ) :: xVector2,yVector2 - DumVec2 = Vector2((/xVector2%x(1)+yVector2%x(1),xVector2%x(2)+yVector2%x(2)/)) + DumVec2 = Vector2([xVector2%x(1)+yVector2%x(1),xVector2%x(2)+yVector2%x(2)]) AddVector2Vector2 = DumVec2 - END FUNCTION AddVector2Vector2 + end function AddVector2Vector2 - FUNCTION AddVectorVector( xVector, yVector ) + function AddVectorVector( xVector, yVector ) ! ! Add two Vector type of variables ! - TYPE( Vector ) AddVectorVector, DumVec - TYPE( Vector ), INTENT( IN ) :: xVector,yVector + type( Vector ) AddVectorVector, DumVec + type( Vector ), intent( in ) :: xVector,yVector - DumVec = Vector((/xVector%x(1)+yVector%x(1),xVector%x(2)+yVector%x(2),xVector%x(3)+yVector%x(3)/)) + DumVec = Vector([xVector%x(1)+yVector%x(1),xVector%x(2)+yVector%x(2),xVector%x(3)+yVector%x(3)]) AddVectorVector = DumVec - END FUNCTION AddVectorVector + end function AddVectorVector - FUNCTION SubtractVector2Vector2( xVector2, yVector2 ) + function SubtractVector2Vector2( xVector2, yVector2 ) ! ! Subtract two Vector2 type of variables ! - TYPE( Vector2 ) SubtractVector2Vector2 - TYPE( Vector2 ), INTENT( IN ) :: xVector2,yVector2 + type( Vector2 ) SubtractVector2Vector2 + type( Vector2 ), intent( in ) :: xVector2,yVector2 SubtractVector2Vector2 = xVector2 + (-1.0_Float)*yVector2 - END FUNCTION SubtractVector2Vector2 + end function SubtractVector2Vector2 - FUNCTION SubtractVectorVector( xVector, yVector ) + function SubtractVectorVector( xVector, yVector ) ! ! Subtract two Vector type of variables ! - TYPE( Vector ) SubtractVectorVector - TYPE( Vector ), INTENT( IN ) :: xVector,yVector + type( Vector ) SubtractVectorVector + type( Vector ), intent( in ) :: xVector,yVector SubtractVectorVector = xVector + (-1.0_Float)*yVector - END FUNCTION SubtractVectorVector + end function SubtractVectorVector - SUBROUTINE Inc(x) - INTEGER, INTENT(INOUT) :: x + subroutine Inc(x) + integer, intent(inout) :: x x = x+1 - END SUBROUTINE Inc + end subroutine Inc - FUNCTION Matrix2SparseMatrix(A) + function Matrix2SparseMatrix(A) ! ! Convert regular matrix to sparse matrix ! - REAL(Float), DIMENSION(:,:), INTENT(IN) :: A + real(Float), dimension(:,:), intent(in) :: A - TYPE(SparseMatrix) :: ASparse,Matrix2SparseMatrix - INTEGER :: N,i,j,NNonZero,iElement + type(SparseMatrix) :: ASparse,Matrix2SparseMatrix + integer :: N,i,j,NNonZero,iElement N = SIZE(A,1) ! ! Count non-zero elements ! NNonZero = 0 - DO i = 1,N - DO j = 1,N - IF (A(j,i).NE.0._Float) NNonZero = NNonZero + 1 - ENDDO - ENDDO + do i = 1,N + do j = 1,N + if (A(j,i) /= 0._Float) NNonZero = NNonZero + 1 + enddo + enddo ASparse%N = NNonZero ! ! Fill sparse array ! - IF (ALLOCATED(ASparse%Element)) DEALLOCATE(ASparse%Element) + if (ALLOCATED(ASparse%Element)) deallocate(ASparse%Element) ASparse%NMax = NNonZero - ALLOCATE(ASparse%Element(NNonZero)) + allocate(ASparse%Element(NNonZero)) iElement = 0 - DO i = 1,N - DO j = 1,N - IF (A(j,i).NE.0._Float) THEN + do i = 1,N + do j = 1,N + if (A(j,i) /= 0._Float) then iElement = iElement + 1 ASparse%Element(iElement)%i = i ASparse%Element(iElement)%j = j ASparse%Element(iElement)%x = A(j,i) - ENDIF - ENDDO - ENDDO + endif + enddo + enddo ! ! Pass result ! Matrix2SparseMatrix = ASparse - END FUNCTION Matrix2SparseMatrix + end function Matrix2SparseMatrix - SUBROUTINE SparseMatrix2Matrix(ASparse,A) + subroutine SparseMatrix2Matrix(ASparse,A) ! ! Convert sparse matrix to regular matrix ! - TYPE(SparseMatrix), INTENT(IN) :: ASparse - REAL(Float), DIMENSION(:,:), INTENT(INOUT) :: A + type(SparseMatrix), intent(in) :: ASparse + real(Float), dimension(:,:), intent(inout) :: A - INTEGER :: iElement + integer :: iElement - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 ! ! Fill array ! A = 0._Float - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,L1,1X,I0,1X,I0)') 'SparseMatrix2Matrix: ',ALLOCATED(ASparse%Element),ASparse%NMax,ASparse%N - ENDIF + if (DebugLevel > 0) then + write(*,'(A,L1,1X,I0,1X,I0)') 'SparseMatrix2Matrix: ',ALLOCATED(ASparse%Element),ASparse%NMax,ASparse%N + endif - DO iElement = 1,ASparse%N - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,I4,1X,I4,1X,EN20.10)') 'i,j,x = ',ASparse%Element(iElement) - ENDIF + do iElement = 1,ASparse%N + if (DebugLevel > 0) then + write(*,'(A,I4,1X,I4,1X,EN20.10)') 'i,j,x = ',ASparse%Element(iElement) + endif A(ASparse%Element(iElement)%j,ASparse%Element(iElement)%i) = ASparse%Element(iElement)%x - ENDDO - END SUBROUTINE SparseMatrix2Matrix + enddo + end subroutine SparseMatrix2Matrix - FUNCTION LMatrix2SparseLMatrix(A) + function LMatrix2SparseLMatrix(A) ! ! Convert regular matrix to sparse matrix ! - LOGICAL, DIMENSION(:,:), INTENT(IN) :: A + logical, dimension(:,:), intent(in) :: A - TYPE(SparseLogicalMatrix) :: LASparse,LMatrix2SparseLMatrix - INTEGER :: N,i,j,NNonZero,iElement + type(SparseLogicalMatrix) :: LASparse,LMatrix2SparseLMatrix + integer :: N,i,j,NNonZero,iElement N = SIZE(A,1) ! ! Count non-zero elements ! NNonZero = 0 - DO i = 1,N - DO j = 1,N - IF (A(j,i)) NNonZero = NNonZero + 1 - ENDDO - ENDDO + do i = 1,N + do j = 1,N + if (A(j,i)) NNonZero = NNonZero + 1 + enddo + enddo LASparse%N = NNonZero ! ! Fill sparse array ! - IF (ALLOCATED(LASparse%Element)) DEALLOCATE(LASparse%Element) + if (ALLOCATED(LASparse%Element)) deallocate(LASparse%Element) LASparse%NMax = NNonZero - ALLOCATE(LASparse%Element(NNonZero)) + allocate(LASparse%Element(NNonZero)) iElement = 0 - DO i = 1,N - DO j = 1,N - IF (A(j,i)) THEN + do i = 1,N + do j = 1,N + if (A(j,i)) then iElement = iElement + 1 LASparse%Element(iElement)%i = i LASparse%Element(iElement)%j = j - ENDIF - ENDDO - ENDDO + endif + enddo + enddo ! ! Pass result ! LMatrix2SparseLMatrix = LASparse - END FUNCTION LMatrix2SparseLMatrix + end function LMatrix2SparseLMatrix - SUBROUTINE SparseLMatrix2LMatrix(LASparse,LA) + subroutine SparseLMatrix2LMatrix(LASparse,LA) ! ! Convert sparse matrix to regular matrix ! - TYPE(SparseLogicalMatrix), INTENT(IN) :: LASparse - LOGICAL, DIMENSION(:,:), INTENT(INOUT) :: LA + type(SparseLogicalMatrix), intent(in) :: LASparse + logical, dimension(:,:), intent(inout) :: LA - INTEGER :: iElement + integer :: iElement - INTEGER, PARAMETER :: DebugLevel = 0 + integer, parameter :: DebugLevel = 0 ! ! Fill array ! LA = .FALSE. - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,L1,1X,I0,1X,I0)') 'SparseLMatrix2LMatrix: ',ALLOCATED(LASparse%Element),LASparse%NMax,LASparse%N - ENDIF + if (DebugLevel > 0) then + write(*,'(A,L1,1X,I0,1X,I0)') 'SparseLMatrix2LMatrix: ',ALLOCATED(LASparse%Element),LASparse%NMax,LASparse%N + endif - DO iElement = 1,LASparse%N - IF (DebugLevel.GT.0) THEN - WRITE(*,'(A,I4,1X,I4)') 'i,j = ',LASparse%Element(iElement)%i,LASparse%Element(iElement)%j - ENDIF + do iElement = 1,LASparse%N + if (DebugLevel > 0) then + write(*,'(A,I4,1X,I4)') 'i,j = ',LASparse%Element(iElement)%i,LASparse%Element(iElement)%j + endif LA(LASparse%Element(iElement)%j,LASparse%Element(iElement)%i) = .TRUE. - ENDDO - END SUBROUTINE SparseLMatrix2LMatrix -END MODULE LibXMath + enddo + end subroutine SparseLMatrix2LMatrix +end module LibXMath diff --git a/src/mature_nuclides.f90 b/src/mature_nuclides.f90 index 34525c6..b5ba928 100644 --- a/src/mature_nuclides.f90 +++ b/src/mature_nuclides.f90 @@ -1,23 +1,27 @@ -PROGRAM MatureNuclides +program MatureNuclides ! This utility reads a nuclide vector at t=0 from file and a delay. ! It returns the aged cocktail. - USE libxmath - USE libutil - USE libendf - USE libpinpoint - - IMPLICIT NONE - - TYPE(CocktailType) :: StartCocktail,OutCocktail,CocktailBefore,CocktailAfter - CHARACTER(DefaultLength) :: FName,TheDirectory,TheFile,TimeStampString,TimeUnitString,ProgenyString,& + use libxmath, only: Float + use libutil, only: DefaultLength, ScratchFile, AllUpCase + use libendf, only: MaxNuclides, NNuclides, NuclideSpecs + use libpinpoint, only: InitLibPinPoint, ReadRIVMSourceTermFile, CocktailType, & + TransitionMatrix, MatureCocktail, & + NStartingTimes, & + DelayGrowthFactor, FirstDelay, AvailableDelay, & + SaveCocktail2 + + implicit none + + type(CocktailType) :: StartCocktail,OutCocktail,CocktailBefore,CocktailAfter + character(DefaultLength) :: FName,TimeStampString,TimeUnitString,ProgenyString,& & DatasetString - REAL(Float), DIMENSION(0:NStartingTimes,MaxNuclides) :: MyActivity,MyRelevantActivity - INTEGER :: NArguements,iLocX,iDelay,iNuclide,NRelevantNuclides,jNuclide,iMother,iDaughter,iPinpoint,iElement - REAL(Float) :: NSecondsDelay,LocX,Alpha,x,Ln2 - LOGICAL, DIMENSION(MaxNuclides) :: IsRelatedToCocktail - CHARACTER(10), DIMENSION(MaxNuclides) :: MyName - LOGICAL :: WithProgeny,UseICRP,MakeWholeSeries - INTEGER, DIMENSION(MaxNuclides) :: MyNuclide + real(Float), dimension(0:NStartingTimes,MaxNuclides) :: MyActivity,MyRelevantActivity + integer :: NArguements,iLocX,iDelay,iNuclide,NRelevantNuclides,jNuclide,iMother,iDaughter,iPinpoint,iElement + real(Float) :: NSecondsDelay,LocX,Alpha,x,Ln2 + logical, dimension(MaxNuclides) :: IsRelatedToCocktail + character(10), dimension(MaxNuclides) :: MyName + logical :: WithProgeny,UseICRP,MakeWholeSeries + integer, dimension(MaxNuclides) :: MyNuclide ! ! Get commmand line arguement: ! @@ -25,117 +29,117 @@ PROGRAM MatureNuclides NArguements = IARGC() - IF (.NOT.((NArguements.EQ.3).OR.(NArguements.EQ.5))) THEN - WRITE(*,'(A)') 'Call:' - WRITE(*,*) - WRITE(*,'(A)') 'mature_nuclides.exe