Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
integer, | intent(in) | :: | ObjectNum | |||
integer, | intent(inout) | :: | NumNewArgsLimit |
Nodes of different colours represent the following:
Solid arrows point from a procedure to one which it calls. Dashed arrows point from an interface to procedures which implement that interface. This could include the module procedures in a generic interface or the implementation in a submodule of an interface in a parent module. Where possible, edges connecting nodes are given different colours to make them easier to distinguish in large graphs.
Nodes of different colours represent the following:
Solid arrows point from a procedure to one which it calls. Dashed arrows point from an interface to procedures which implement that interface. This could include the module procedures in a generic interface or the implementation in a submodule of an interface in a parent module. Where possible, edges connecting nodes are given different colours to make them easier to distinguish in large graphs.
SUBROUTINE ExtendObjectDefinition(ObjectNum,NumNewArgsLimit)
! SUBROUTINE INFORMATION:
! AUTHOR Linda Lawrie
! DATE WRITTEN Sep 2008
! MODIFIED na
! RE-ENGINEERED na
! PURPOSE OF THIS SUBROUTINE:
! This routine expands the object definition according to the extensible "rules" entered
! by the developer. The developer should enter the number of fields to be duplicated.
! See References section for examples.
! METHODOLOGY EMPLOYED:
! The routine determines the type of the fields to be added (A or N) and reallocates the
! appropriate arrays in the object definition structure.
! REFERENCES:
! Extensible objects have a \extensible:<num> specification
! \extensible:3 -- the last 3 fields are "extended"
! Works on this part of the definition:
! INTEGER :: NumParams =0 ! Number of parameters to be processed for each object
! INTEGER :: NumAlpha =0 ! Number of Alpha elements in the object
! INTEGER :: NumNumeric =0 ! Number of Numeric elements in the object
! LOGICAL(1), ALLOCATABLE, DIMENSION(:) :: AlphaorNumeric ! Positionally, whether the argument
! ! is alpha (true) or numeric (false)
! LOGICAL(1), ALLOCATABLE, DIMENSION(:) :: ReqField ! True for required fields
! LOGICAL(1), ALLOCATABLE, DIMENSION(:) :: AlphRetainCase ! true if retaincase is set for this field (alpha fields only)
! CHARACTER(len=MaxNameLength+40), &
! ALLOCATABLE, DIMENSION(:) :: AlphFieldChks ! Field names for alphas
! CHARACTER(len=MaxNameLength), &
! ALLOCATABLE, DIMENSION(:) :: AlphFieldDefs ! Defaults for alphas
! TYPE(RangeCheckDef), ALLOCATABLE, DIMENSION(:) :: NumRangeChks ! Used to range check and default numeric fields
! INTEGER :: LastExtendAlpha =0 ! Count for extended alpha fields
! INTEGER :: LastExtendNum =0 ! Count for extended numeric fields
! USE STATEMENTS:
! na
IMPLICIT NONE ! Enforce explicit typing of all variables in this routine
! SUBROUTINE ARGUMENT DEFINITIONS:
INTEGER, INTENT(IN) :: ObjectNum ! Number of the object definition to be extended.
INTEGER, INTENT(INOUT) :: NumNewArgsLimit ! Number of the parameters after extension
! SUBROUTINE PARAMETER DEFINITIONS:
INTEGER, PARAMETER :: NewAlloc=1000 ! number of new items to allocate (* number of fields)
! INTERFACE BLOCK SPECIFICATIONS:
! na
! DERIVED TYPE DEFINITIONS:
! na
! SUBROUTINE LOCAL VARIABLE DECLARATIONS:
INTEGER :: NumAlphaField
INTEGER :: NumNumericField
INTEGER :: NumNewAlphas
INTEGER :: NumNewNumerics
INTEGER :: NumNewParams
INTEGER :: NumExtendFields
INTEGER :: NumParams
INTEGER :: Loop
INTEGER :: Count
INTEGER :: Item
! LOGICAL :: MaxArgsChanged
LOGICAL, DIMENSION(:), ALLOCATABLE :: AorN
LOGICAL, DIMENSION(:), ALLOCATABLE :: TempLogical
REAL(r64), DIMENSION(:), ALLOCATABLE :: TempReals
CHARACTER(len=MaxFieldNameLength), DIMENSION(:), ALLOCATABLE :: TempFieldCharacter
CHARACTER(len=MaxNameLength), DIMENSION(:), ALLOCATABLE :: TempCharacter
CHARACTER(len=32) :: charout
TYPE(RangeCheckDef), ALLOCATABLE, DIMENSION(:) :: TempChecks
CHARACTER(len=MaxNameLength), SAVE :: CurObject
write(EchoInputFile,'(A)') 'Attempting to auto-extend object='//TRIM(ObjectDef(ObjectNum)%Name)
IF (CurObject /= ObjectDef(ObjectNum)%Name) THEN
CALL DisplayString('Auto-extending object="'//trim(ObjectDef(ObjectNum)%Name)//'", input processing may be slow.')
CurObject=ObjectDef(ObjectNum)%Name
ENDIF
NumAlphaField=0
NumNumericField=0
NumParams=ObjectDef(ObjectNum)%NumParams
Count=NumParams-ObjectDef(ObjectNum)%ExtensibleNum+1
! MaxArgsChanged=.false.
ALLOCATE(AorN(ObjectDef(ObjectNum)%ExtensibleNum))
AorN=.false.
do Loop=NumParams,Count,-1
if (ObjectDef(ObjectNum)%AlphaOrNumeric(Loop)) then
NumAlphaField=NumAlphaField+1
else
NumNumericField=NumNumericField+1
endif
enddo
Item=0
do Loop=Count,NumParams
Item=Item+1
AorN(Item)=ObjectDef(ObjectNum)%AlphaOrNumeric(Loop)
enddo
NumNewAlphas=NumAlphaField*NewAlloc
NumNewNumerics=NumNumericField*NewAlloc
NumNewParams=NumParams+NumNewAlphas+NumNewNumerics
NumExtendFields=NumAlphaField+NumNumericField
ALLOCATE(TempLogical(NumNewParams))
TempLogical(1:NumParams)=ObjectDef(ObjectNum)%AlphaOrNumeric
TempLogical(NumParams+1:NumNewParams)=.false.
DEALLOCATE(ObjectDef(ObjectNum)%AlphaOrNumeric)
ALLOCATE(ObjectDef(ObjectNum)%AlphaOrNumeric(NumNewParams))
ObjectDef(ObjectNum)%AlphaOrNumeric=TempLogical
DEALLOCATE(TempLogical)
do Loop=NumParams+1,NumNewParams,NumExtendFields
ObjectDef(ObjectNum)%AlphaOrNumeric(Loop:Loop+NumExtendFields-1)=AorN
enddo
DEALLOCATE(AorN) ! done with this object AorN array.
! required fields -- can't be extended and required.
ALLOCATE(TempLogical(NumNewParams))
TempLogical(1:NumParams)=ObjectDef(ObjectNum)%ReqField
TempLogical(NumParams+1:NumNewParams)=.false.
DEALLOCATE(ObjectDef(ObjectNum)%ReqField)
ALLOCATE(ObjectDef(ObjectNum)%ReqField(NumNewParams))
ObjectDef(ObjectNum)%ReqField=TempLogical
DEALLOCATE(TempLogical)
ALLOCATE(TempLogical(NumNewParams))
TempLogical(1:NumParams)=ObjectDef(ObjectNum)%AlphRetainCase
TempLogical(NumParams+1:NumNewParams)=.false.
DEALLOCATE(ObjectDef(ObjectNum)%AlphRetainCase)
ALLOCATE(ObjectDef(ObjectNum)%AlphRetainCase(NumNewParams))
ObjectDef(ObjectNum)%AlphRetainCase=TempLogical
DEALLOCATE(TempLogical)
if (NumAlphaField > 0) then
ALLOCATE(TempFieldCharacter(ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas))
TempFieldCharacter(1:ObjectDef(ObjectNum)%NumAlpha)=ObjectDef(ObjectNum)%AlphFieldChks
TempFieldCharacter(ObjectDef(ObjectNum)%NumAlpha+1:ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas)=Blank
DEALLOCATE(ObjectDef(ObjectNum)%AlphFieldChks)
ALLOCATE(ObjectDef(ObjectNum)%AlphFieldChks(ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas))
ObjectDef(ObjectNum)%AlphFieldChks=TempFieldCharacter
DEALLOCATE(TempFieldCharacter)
do Loop=ObjectDef(ObjectNum)%NumAlpha+1,ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas
ObjectDef(ObjectNum)%LastExtendAlpha=ObjectDef(ObjectNum)%LastExtendAlpha+1
charout=IPTrimSigDigits(ObjectDef(ObjectNum)%LastExtendAlpha)
ObjectDef(ObjectNum)%AlphFieldChks(Loop)='Extended Alpha Field '//TRIM(charout)
enddo
ALLOCATE(TempCharacter(ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas))
TempCharacter(1:ObjectDef(ObjectNum)%NumAlpha)=ObjectDef(ObjectNum)%AlphFieldDefs
TempCharacter(ObjectDef(ObjectNum)%NumAlpha+1:ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas)=Blank
DEALLOCATE(ObjectDef(ObjectNum)%AlphFieldDefs)
ALLOCATE(ObjectDef(ObjectNum)%AlphFieldDefs(ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas))
ObjectDef(ObjectNum)%AlphFieldDefs=TempCharacter
DEALLOCATE(TempCharacter)
if (ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas > MaxAlphaArgsFound) then
! must redimension LineItem args
ALLOCATE(TempCharacter(ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas))
TempCharacter(1:ObjectDef(ObjectNum)%NumAlpha)=LineItem%Alphas
TempCharacter(ObjectDef(ObjectNum)%NumAlpha+1:ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas)=Blank
DEALLOCATE(LineItem%Alphas)
ALLOCATE(LineItem%Alphas(ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas))
LineItem%Alphas=TempCharacter
DEALLOCATE(TempCharacter)
ALLOCATE(TempLogical(ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas))
TempLogical(1:ObjectDef(ObjectNum)%NumAlpha)=LineItem%AlphBlank
TempLogical(ObjectDef(ObjectNum)%NumAlpha+1:ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas)=.true.
DEALLOCATE(LineItem%AlphBlank)
ALLOCATE(LineItem%AlphBlank(ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas))
LineItem%AlphBlank=TempLogical
DEALLOCATE(TempLogical)
MaxAlphaArgsFound=ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas
! MaxArgsChanged=.true.
endif
endif
if (NumNumericField > 0) then
ALLOCATE(TempChecks(ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics))
TempChecks(1:ObjectDef(ObjectNum)%NumNumeric)=ObjectDef(ObjectNum)%NumRangeChks
DEALLOCATE(ObjectDef(ObjectNum)%NumRangeChks)
ALLOCATE(ObjectDef(ObjectNum)%NumRangeChks(ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics))
ObjectDef(ObjectNum)%NumRangeChks=TempChecks
DEALLOCATE(TempChecks)
do Loop=ObjectDef(ObjectNum)%NumNumeric+1,ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics
ObjectDef(ObjectNum)%NumRangeChks(Loop)%FieldNumber=Loop
ObjectDef(ObjectNum)%LastExtendNum=ObjectDef(ObjectNum)%LastExtendNum+1
charout=IPTrimSigDigits(ObjectDef(ObjectNum)%LastExtendNum)
ObjectDef(ObjectNum)%NumRangeChks(Loop)%FieldName='Extended Numeric Field '//TRIM(charout)
enddo
if (ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics > MaxNumericArgsFound) then
! must redimension LineItem args
ALLOCATE(TempReals(ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics))
TempReals(1:ObjectDef(ObjectNum)%NumNumeric)=LineItem%Numbers
TempReals(ObjectDef(ObjectNum)%NumNumeric+1:ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics)=0.0d0
DEALLOCATE(LineItem%Numbers)
ALLOCATE(LineItem%Numbers(ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics))
LineItem%Numbers=TempReals
DEALLOCATE(TempReals)
ALLOCATE(TempLogical(ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics))
TempLogical(1:ObjectDef(ObjectNum)%NumNumeric)=LineItem%NumBlank
TempLogical(ObjectDef(ObjectNum)%NumNumeric+1:ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics)=.true.
DEALLOCATE(LineItem%NumBlank)
ALLOCATE(LineItem%NumBlank(ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics))
LineItem%NumBlank=TempLogical
DEALLOCATE(TempLogical)
MaxNumericArgsFound=ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics
! MaxArgsChanged=.true.
endif
endif
ObjectDef(ObjectNum)%NumParams=NumNewParams
NumNewArgsLimit=NumNewParams
ObjectDef(ObjectNum)%NumAlpha=ObjectDef(ObjectNum)%NumAlpha+NumNewAlphas
ObjectDef(ObjectNum)%NumNumeric=ObjectDef(ObjectNum)%NumNumeric+NumNewNumerics
RETURN
END SUBROUTINE ExtendObjectDefinition