From 9968221f919b076b75cc330cf5c311cf6bdceb0c Mon Sep 17 00:00:00 2001 From: "Hrant P. Hratchian" Date: Mon, 13 Jul 2026 18:46:42 -0700 Subject: [PATCH] Updated the version to 26.7.0. --- .other_libs/build_fcns/configure.ac_FormCHK | 2 +- .../build_fcns/configure.ac_MatrixFile | 2 +- README.md | 5 +- releaseNotes.txt | 5 + src/mqc_FullWavefunction.F03 | 4 +- src/mqc_algebra.F03 | 4 +- src/mqc_algebra2.F03 | 714 ++++++++++++++++-- src/mqc_binary.F03 | 4 +- src/mqc_datastructures.F03 | 4 +- src/mqc_est.F03 | 4 +- src/mqc_files.F03 | 4 +- src/mqc_gaussian.F03 | 51 +- src/mqc_general.F03 | 267 ++++++- src/mqc_general_lapack.F03 | 4 +- src/mqc_integrals.F03 | 4 +- src/mqc_interface.F03 | 4 +- src/mqc_matwrapper.F03 | 243 +++++- src/mqc_molecule.F03 | 4 +- unitTests/src/makefile | 2 +- unitTests/src/unitTest02.f03 | 295 ++++++++ 20 files changed, 1515 insertions(+), 111 deletions(-) create mode 100644 unitTests/src/unitTest02.f03 diff --git a/.other_libs/build_fcns/configure.ac_FormCHK b/.other_libs/build_fcns/configure.ac_FormCHK index 6ba8b451..493aca3d 100644 --- a/.other_libs/build_fcns/configure.ac_FormCHK +++ b/.other_libs/build_fcns/configure.ac_FormCHK @@ -1,4 +1,4 @@ -AC_INIT([MQC_Pack], [25.11.2], [hhratchian@ucmerced.edu]) +AC_INIT([MQC_Pack], [26.7.0], [hhratchian@ucmerced.edu]) AM_INIT_AUTOMAKE([foreign]) AC_CONFIG_SRCDIR([src/mqc_general.F03]) AC_PROG_CPP diff --git a/.other_libs/build_fcns/configure.ac_MatrixFile b/.other_libs/build_fcns/configure.ac_MatrixFile index 8a5804f1..4dcb1677 100644 --- a/.other_libs/build_fcns/configure.ac_MatrixFile +++ b/.other_libs/build_fcns/configure.ac_MatrixFile @@ -1,4 +1,4 @@ -AC_INIT([MQC_Pack], [25.11.2], [hhratchian@ucmerced.edu]) +AC_INIT([MQC_Pack], [26.7.0], [hhratchian@ucmerced.edu]) AM_INIT_AUTOMAKE([foreign]) AC_CONFIG_SRCDIR([src/mqc_general.F03]) AC_LANG([Fortran]) diff --git a/README.md b/README.md index ea36d04c..73aa3fca 100644 --- a/README.md +++ b/README.md @@ -16,8 +16,8 @@ ** ** ** The Merced Quantum Chemistry Package ** ** (MQCPack) ** - ** Version 25.11.2 ** - ** November 11, 2025 ** + ** Version 26.7.0 ** + ** July 13, 2026 ** ** ** ** ** ** Written By: ** @@ -91,4 +91,3 @@ software is, your program will work without any modifications. # Licence This project is licensed under the Apache License - see the LICENSE file for details - diff --git a/releaseNotes.txt b/releaseNotes.txt index 7be16d6c..0ddd6d12 100644 --- a/releaseNotes.txt +++ b/releaseNotes.txt @@ -8,6 +8,11 @@ number updates will be documented here. Note that the minor version number will often be updated near the start of the month and the revision number in that case will be set to 0. +July 13, 2026 +* MQCPack version set to 26.7.0. +* Added character handling to MQC_Variable objects in MQC_Algebra2. +* Several minor code clean-ups and minor feature extensions. + November 10, 2025 * MQCPack version set to 25.11.1. * Added a wrapper in MQC_General_LAPack for DGESV, which is used for linear diff --git a/src/mqc_FullWavefunction.F03 b/src/mqc_FullWavefunction.F03 index dec450c7..141cc799 100644 --- a/src/mqc_FullWavefunction.F03 +++ b/src/mqc_FullWavefunction.F03 @@ -11,8 +11,8 @@ module MQC_FullWavefunction ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 6d4bbc2b..595dc0ef 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -43,8 +43,8 @@ Module MQC_Algebra ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/src/mqc_algebra2.F03 b/src/mqc_algebra2.F03 index 72f6dd04..4a4cb097 100644 --- a/src/mqc_algebra2.F03 +++ b/src/mqc_algebra2.F03 @@ -12,8 +12,8 @@ Module MQC_Algebra2 ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** @@ -43,8 +43,8 @@ Module MQC_Algebra2 !MD- ! - Use MQC_General - use iso_fortran_env, only: int64, real64 + Use MQC_General, String_Change_Case_Intrinsic => String_Change_Case + use iso_fortran_env,only:int64,real64 ! !---------------------------------------------------------------- ! | @@ -54,18 +54,19 @@ Module MQC_Algebra2 ! ! Variable... ! -! The MQC_Variable class is a flexible numerical structure. MQC_Variable +! The MQC_Variable class is a flexible data structure. MQC_Variable ! objects may represent scalars, vectors, matrices, or general tensors. ! Additionally, MQC_Variable objects may represent such structures as -! integer, real, or complex types. The goal is for such objects to be used -! in general form, abstracting away storage format and the like. +! integer, real, complex, or character types. The goal is for such objects +! to be used in general form, abstracting away storage format and the like. ! ! Elements of the MQC_Variable class include: ! - rank The rank of the numerical array structure. This value ! defaults to -1 to indicate that the object has not yet ! been initialized. ! - dataType This character string encodes the data type of the -! object as "INTEGER", "REAL", or "COMPLEX". +! object as "INTEGER", "REAL", "COMPLEX", or +! "CHARACTER". type MQC_Variable integer(kind=int64),private::rank=-1 !hph character(len=64),private::dataType,storageFormat @@ -74,25 +75,36 @@ Module MQC_Algebra2 real(kind=real64),dimension(:),allocatable::realArray complex(kind=real64),dimension(:),allocatable::complexArray integer(kind=int64),dimension(:),allocatable,private::integerArray + character(len=:),dimension(:),allocatable,private::characterArray logical,private::initialized=.false. Contains procedure,public::init => MQC_Variable_initialize procedure,private::MQC_Variable_clear_mqc procedure,private::MQC_Variable_clear_integer procedure,private::MQC_Variable_clear_real + procedure,private::MQC_Variable_clear_character generic,public ::clear => MQC_Variable_clear_mqc, & MQC_Variable_clear_integer, & - MQC_Variable_clear_real + MQC_Variable_clear_real, & + MQC_Variable_clear_character procedure,private::MQC_Variable_put_MQC procedure,private::MQC_Variable_put_intrinsicInteger procedure,private::MQC_Variable_put_intrinsicReal + procedure,private::MQC_Variable_put_intrinsicCharacter procedure,public ::putMQC => MQC_Variable_put_MQC generic,public ::put => MQC_Variable_put_MQC, & MQC_Variable_put_intrinsicInteger, & - MQC_Variable_put_intrinsicReal + MQC_Variable_put_intrinsicReal, & + MQC_Variable_put_intrinsicCharacter procedure,public ::getVal => MQC_Variable_get_MQC procedure,public ::getRank => MQC_Variable_getRank procedure,public ::getType => MQC_Variable_getType + procedure,public ::getCharacterLength => MQC_Variable_getCharacterLength + procedure,public ::change_case => MQC_Variable_Change_Case + procedure,public ::adjustl => MQC_Variable_AdjustL + procedure,public ::adjustr => MQC_Variable_AdjustR + procedure,public ::len_trim => MQC_Variable_Len_Trim + procedure,public ::trim => MQC_Variable_Trim procedure,public ::print => MQC_Print_mqcVariable procedure,public ::isConformable => MQC_Variable_isConformable procedure,public ::trimZero => mqc_variable_trimZero @@ -129,8 +141,34 @@ Module MQC_Algebra2 module procedure MQC_Variable_reshape end interface ! -! Interface intrinsic real/integer to MQC variable. +! Interface character MQC Variables to the LEN intrinsic function. + interface len + module procedure MQC_Variable_getCharacterLength + end interface +! +! Interface character MQC Variables to intrinsic character functions. + interface adjustl + module procedure MQC_Variable_AdjustL + end interface + interface adjustr + module procedure MQC_Variable_AdjustR + end interface + interface len_trim + module procedure MQC_Variable_Len_Trim + end interface + interface trim + module procedure MQC_Variable_Trim + end interface +! +! Extend String_Change_Case to operate on MQC Variables. + interface String_Change_Case + procedure String_Change_Case_Intrinsic + module procedure MQC_Variable_Change_Case + end interface +! +! Interface intrinsic character/real/integer to MQC variable. interface mqc + module procedure MQC_Variable_from_intrinsicCharacter module procedure MQC_Variable_from_intrinsicInteger module procedure MQC_Variable_from_intrinsicReal end interface @@ -166,14 +204,17 @@ Module MQC_Algebra2 ! Interface routines that clear MQC variable objects. interface MQC_Variable_clear module procedure MQC_Variable_clear_mqc + module procedure MQC_Variable_clear_character module procedure MQC_Variable_clear_integer module procedure MQC_Variable_clear_real end interface ! ! Interface routines that fill MQC variable objects. interface mqc_variable_fillVal + module procedure MQC_Variable_setVal_intrinsicScalar2mqcScalar_character module procedure MQC_Variable_setVal_intrinsicScalar2mqcScalar_integer module procedure MQC_Variable_setVal_intrinsicScalar2mqcScalar_real + module procedure MQC_Variable_setVal_intrinsicVector2mqcVector_character module procedure MQC_Variable_setVal_intrinsicVector2mqcVector_integer module procedure MQC_Variable_setVal_intrinsicVector2mqcVector_real module procedure MQC_Variable_setVal_intrinsicMatrix2mqcMatrix_integer @@ -184,6 +225,7 @@ Module MQC_Algebra2 ! Interface routines that fill specific elements of MQC variable objects. interface mqc_variable_put module procedure MQC_Variable_put_MQC + module procedure MQC_Variable_put_intrinsicCharacter module procedure MQC_Variable_put_intrinsicInteger module procedure MQC_Variable_put_intrinsicReal end interface @@ -219,8 +261,10 @@ Module MQC_Algebra2 ! ! Assignment and type conversion interface (=). interface assignment (=) + module procedure MQC_Variable_setVal_intrinsicScalar2mqcScalar_character module procedure MQC_Variable_setVal_intrinsicScalar2mqcScalar_integer module procedure MQC_Variable_setVal_intrinsicScalar2mqcScalar_real + module procedure MQC_Variable_setVal_intrinsicVector2mqcVector_character module procedure MQC_Variable_setVal_intrinsicVector2mqcVector_integer module procedure MQC_Variable_setVal_intrinsicVector2mqcVector_real module procedure MQC_Variable_setVal_intrinsicMatrix2mqcMatrix_integer @@ -233,6 +277,8 @@ Module MQC_Algebra2 module procedure MQC_Variable_mqc2intrinsicInteger2Array module procedure MQC_Variable_mqc2intrinsicReal2Array module procedure MQC_Variable_mqc2intrinsicReal4Array + module procedure MQC_Variable_mqc2intrinsicCharacterScalar + module procedure MQC_Variable_mqc2intrinsicCharacter1Array end interface ! ! Whole-array addition (+). @@ -368,12 +414,12 @@ end subroutine MQC_Algebra2_SetDEBUG ! !PROCEDURE MQC_Variable_initialize subroutine MQC_Variable_initialize(mqcVariable,dataType,dimensions, & - rank,storageFormat,debug) + rank,storageFormat,debug,characterLength) ! ! This subroutine is used to initialize an MQC_Variable object. ! ! -! H. P. Hratchian, 2017. +! H. P. Hratchian, 2017, 2026. ! ! ! Variable Declarations. @@ -384,9 +430,10 @@ subroutine MQC_Variable_initialize(mqcVariable,dataType,dimensions, & integer(kind=int64),intent(in),optional::rank character(len=*),intent(in),optional::storageFormat logical,intent(in),optional::debug + integer(kind=int64),intent(in),optional::characterLength ! character(len=64)::myDataType - integer(kind=int64)::myRank,myLength + integer(kind=int64)::myRank,myLength,myCharacterLength character(len=64)::myStorageFormat logical::myDebug ! @@ -433,10 +480,15 @@ subroutine MQC_Variable_initialize(mqcVariable,dataType,dimensions, & mqcVariable%dataType = 'REAL' case('INTEGER','INT','I') mqcVariable%dataType = 'INTEGER' + case('CHARACTER','CHAR','C') + mqcVariable%dataType = 'CHARACTER' case default call MQC_Error_A('Initializing MQC_Variable with unknown'// & ' data type.', 6,'myDataType', myDataType) end select + if(mqcVariable%dataType.eq.'CHARACTER'.and.myRank.gt.1) & + call MQC_Error_I('Character MQC_Variable objects currently support '// & + 'only scalars and vectors.',6,'myRank',myRank) ! ! Take care of rank and dimensions. ! @@ -474,8 +526,12 @@ subroutine MQC_Variable_initialize(mqcVariable,dataType,dimensions, & select case(mqcVariable%dataType) case('REAL') + if(Allocated(mqcVariable%complexArray)) & + DeAllocate(mqcVariable%complexArray) if(Allocated(mqcVariable%integerArray)) & DeAllocate(mqcVariable%integerArray) + if(Allocated(mqcVariable%characterArray)) & + DeAllocate(mqcVariable%characterArray) if(.not.Allocated(mqcVariable%realArray)) then Allocate(mqcVariable%realArray(myLength)) elseIf(Size(mqcVariable%realArray).ne.myLength) then @@ -483,13 +539,41 @@ subroutine MQC_Variable_initialize(mqcVariable,dataType,dimensions, & Allocate(mqcVariable%realArray(myLength)) endIf case('INTEGER') + if(Allocated(mqcVariable%complexArray)) & + DeAllocate(mqcVariable%complexArray) if(Allocated(mqcVariable%realArray)) DeAllocate(mqcVariable%realArray) + if(Allocated(mqcVariable%characterArray)) & + DeAllocate(mqcVariable%characterArray) if(.not.Allocated(mqcVariable%integerArray)) then Allocate(mqcVariable%integerArray(myLength)) elseIf(Size(mqcVariable%integerArray).ne.myLength) then DeAllocate(mqcVariable%integerArray) Allocate(mqcVariable%integerArray(myLength)) endIf + case('CHARACTER') + if(PRESENT(characterLength)) then + myCharacterLength = characterLength + else + call mqc_error('MQC_Variable_initialize: characterLength is '// & + 'required for CHARACTER variables.',6) + myCharacterLength = 0 + endIf + if(myCharacterLength.lt.0) & + call MQC_Error_I('MQC_Variable_initialize: characterLength must '// & + 'not be negative.',6,'myCharacterLength',myCharacterLength) + if(Allocated(mqcVariable%realArray)) DeAllocate(mqcVariable%realArray) + if(Allocated(mqcVariable%complexArray)) & + DeAllocate(mqcVariable%complexArray) + if(Allocated(mqcVariable%integerArray)) & + DeAllocate(mqcVariable%integerArray) + if(Allocated(mqcVariable%characterArray)) then + if(Size(mqcVariable%characterArray).ne.myLength.or. & + LEN(mqcVariable%characterArray).ne.myCharacterLength) & + DeAllocate(mqcVariable%characterArray) + endIf + if(.not.Allocated(mqcVariable%characterArray)) & + Allocate(character(len=myCharacterLength):: & + mqcVariable%characterArray(myLength)) case default call MQC_Error_A('MQC_Variable_initialize is confused in '// & 'allocation block.',6,'mqcVariable%dataType', & @@ -592,6 +676,32 @@ function MQC_Variable_getLength(mqcVariable) result(myLen) end function MQC_Variable_getLength +! +!PROCEDURE MQC_Variable_getCharacterLength + function MQC_Variable_getCharacterLength(mqcVariable) result(myLen) +! +! This function returns the declared element length of a character +! MQC_Variable scalar or vector. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(in)::mqcVariable + integer(kind=int64)::myLen +! +! + if(.not.mqcVariable%initialized) & + call mqc_error('Cannot call LEN for an uninitialized MQC_Variable.',6) + if(TRIM(mqcVariable%getType()).ne.'CHARACTER') & + call mqc_error_a('LEN is only defined for character MQC_Variable '// & + 'objects.',6,'mqcVariable%getType()',mqcVariable%getType()) + myLen = LEN(mqcVariable%characterArray) +! + return + end function MQC_Variable_getCharacterLength + + ! !PROCEDURE MQC_Variable_getRank function MQC_Variable_getRank(mqcVariable) result(myRank) @@ -670,7 +780,7 @@ function MQC_Variable_reshape(mqcVariable,newShape) result(mqcVariableNew) ! This function reshapes an MQC variable array. ! ! -! H. P. Hratchian, 2025. +! H. P. Hratchian, 2025, 2026. ! ! ! Variable Declarations. @@ -682,6 +792,10 @@ function MQC_Variable_reshape(mqcVariable,newShape) result(mqcVariableNew) ! if(PRODUCT(newShape).ne.SIZE(mqcVariable)) & call mqc_error('RESHAPE: Inconsistend new shape and size.') + if(TRIM(mqcVariable%getType()).eq.'CHARACTER'.and. & + SIZE(newShape).gt.1) & + call mqc_error('RESHAPE: Character MQC_Variable objects currently '// & + 'support only scalars and vectors.',6) mqcVariableNew = mqcVariable mqcVariableNew%dimensions=0 mqcVariableNew%dimensions(1:SIZE(newShape))=newShape @@ -701,9 +815,10 @@ function MQC_Variable_getType(mqcVariable) result(myType) ! 'UNKNOWN' ... Indicates an unknown data type has been found. ! 'REAL' ... Indicates the type of mqcVariable is real. ! 'INTEGER' ... Indicates the type of mqcVariable is integer. +! 'CHARACTER' ... Indicates the type of mqcVariable is character. ! ! -! H. P. Hratchian, 2017. +! H. P. Hratchian, 2017, 2026. ! ! ! Variable Declarations. @@ -720,6 +835,8 @@ function MQC_Variable_getType(mqcVariable) result(myType) myType = 'REAL' case('INTEGER') myType = 'INTEGER' + case('CHARACTER') + myType = 'CHARACTER' case default myType = 'UNKNOWN' end select @@ -737,18 +854,18 @@ function MQC_Variable_getTypeCode(mqcVariable) result(myTypeCode) ! This function is only used in this module to make type mixing/conversion ! during operations consistent throughout the module. ! -! NOTE: The type codes returned by this function are ordered by actual -! underlying typing such that lower valued codes indicated higher-precedent -! types. In other words, type-code 3 can always be treated as a type-code 2 -! value, but the reverse is not generally true. +! NOTE: Numerical type codes 2 and 3 are ordered such that the lower code +! has higher precedence. Character type code 4 does not participate in +! numerical promotion. ! ! The output values are: ! 0 ... UNKNOWN ! 2 ... REAL ! 3 ... INTEGER +! 4 ... CHARACTER ! ! -! H. P. Hratchian, 2017. +! H. P. Hratchian, 2017, 2026. ! ! ! Variable Declarations. @@ -764,6 +881,8 @@ function MQC_Variable_getTypeCode(mqcVariable) result(myTypeCode) myTypeCode = 2 case('INTEGER') myTypeCode = 3 + case('CHARACTER') + myTypeCode = 4 case default myTypeCode = 0 end select @@ -865,6 +984,195 @@ subroutine MQC_Variable_getShape(mqcVariable,iShape) end subroutine MQC_Variable_getShape +! +!PROCEDURE MQC_Variable_AdjustL + function MQC_Variable_AdjustL(mqcVariable) result(mqcVariableOut) +! +! This function applies ADJUSTL to a character MQC_Variable scalar or +! vector through the intrinsic-character kernel in MQC_General. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(in)::mqcVariable + type(MQC_Variable)::mqcVariableOut +! +! + if(.not.mqcVariable%initialized) & + call mqc_error('Cannot apply ADJUSTL to an uninitialized '// & + 'MQC_Variable.',6) + if(TRIM(mqcVariable%getType()).ne.'CHARACTER') & + call mqc_error_a('ADJUSTL requires a character MQC_Variable.',6, & + 'mqcVariable%getType()',mqcVariable%getType()) +! + mqcVariableOut = mqcVariable + select case(RANK(mqcVariable)) + case(0) + mqcVariableOut%characterArray(1) = & + mqc_adjustl(mqcVariable%characterArray(1)) + case(1) + mqcVariableOut%characterArray = & + mqc_adjustl(mqcVariable%characterArray) + case default + call mqc_error_i('ADJUSTL found an unsupported character '// & + 'MQC_Variable rank.',6,'RANK(mqcVariable)',RANK(mqcVariable)) + end select +! + return + end function MQC_Variable_AdjustL + + +! +!PROCEDURE MQC_Variable_AdjustR + function MQC_Variable_AdjustR(mqcVariable) result(mqcVariableOut) +! +! This function applies ADJUSTR to a character MQC_Variable scalar or +! vector through the intrinsic-character kernel in MQC_General. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(in)::mqcVariable + type(MQC_Variable)::mqcVariableOut +! +! + if(.not.mqcVariable%initialized) & + call mqc_error('Cannot apply ADJUSTR to an uninitialized '// & + 'MQC_Variable.',6) + if(TRIM(mqcVariable%getType()).ne.'CHARACTER') & + call mqc_error_a('ADJUSTR requires a character MQC_Variable.',6, & + 'mqcVariable%getType()',mqcVariable%getType()) +! + mqcVariableOut = mqcVariable + select case(RANK(mqcVariable)) + case(0) + mqcVariableOut%characterArray(1) = & + mqc_adjustr(mqcVariable%characterArray(1)) + case(1) + mqcVariableOut%characterArray = & + mqc_adjustr(mqcVariable%characterArray) + case default + call mqc_error_i('ADJUSTR found an unsupported character '// & + 'MQC_Variable rank.',6,'RANK(mqcVariable)',RANK(mqcVariable)) + end select +! + return + end function MQC_Variable_AdjustR + + +! +!PROCEDURE MQC_Variable_Len_Trim + function MQC_Variable_Len_Trim(mqcVariable) result(mqcVariableOut) +! +! This function applies LEN_TRIM to a character MQC_Variable. The result is +! an integer MQC_Variable with the same scalar or vector rank. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(in)::mqcVariable + type(MQC_Variable)::mqcVariableOut +! +! + if(.not.mqcVariable%initialized) & + call mqc_error('Cannot apply LEN_TRIM to an uninitialized '// & + 'MQC_Variable.',6) + if(TRIM(mqcVariable%getType()).ne.'CHARACTER') & + call mqc_error_a('LEN_TRIM requires a character MQC_Variable.',6, & + 'mqcVariable%getType()',mqcVariable%getType()) +! + select case(RANK(mqcVariable)) + case(0) + mqcVariableOut = mqc_len_trim(mqcVariable%characterArray(1)) + case(1) + mqcVariableOut = mqc_len_trim(mqcVariable%characterArray) + case default + call mqc_error_i('LEN_TRIM found an unsupported character '// & + 'MQC_Variable rank.',6,'RANK(mqcVariable)',RANK(mqcVariable)) + end select +! + return + end function MQC_Variable_Len_Trim + + +! +!PROCEDURE MQC_Variable_Trim + function MQC_Variable_Trim(mqcVariable) result(mqcVariableOut) +! +! This function applies TRIM to a character MQC_Variable scalar through +! the intrinsic-character kernel in MQC_General. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(in)::mqcVariable + type(MQC_Variable)::mqcVariableOut +! +! + if(.not.mqcVariable%initialized) & + call mqc_error('Cannot apply TRIM to an uninitialized '// & + 'MQC_Variable.',6) + if(TRIM(mqcVariable%getType()).ne.'CHARACTER') & + call mqc_error_a('TRIM requires a character MQC_Variable.',6, & + 'mqcVariable%getType()',mqcVariable%getType()) + if(RANK(mqcVariable).ne.0) & + call mqc_error_i('TRIM currently requires a character scalar '// & + 'MQC_Variable.',6,'RANK(mqcVariable)',RANK(mqcVariable)) +! + mqcVariableOut = mqc_trim(mqcVariable%characterArray(1)) +! + return + end function MQC_Variable_Trim + + +! +!PROCEDURE MQC_Variable_Change_Case + subroutine MQC_Variable_Change_Case(mqcVariable,upperLower, & + mqcVariableOut) +! +! This routine changes the case of every element of a character +! MQC_Variable. If mqcVariableOut is present, the input object is retained +! and the changed copy is returned through mqcVariableOut. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(inOut)::mqcVariable + character(len=1),intent(in)::upperLower + type(MQC_Variable),intent(out),optional::mqcVariableOut +! + integer(kind=int64)::i +! +! + if(.not.mqcVariable%initialized) & + call mqc_error('Cannot change case of an uninitialized '// & + 'MQC_Variable.',6) + if(TRIM(mqcVariable%getType()).ne.'CHARACTER') & + call mqc_error_a('MQC_Variable_Change_Case requires a character '// & + 'MQC_Variable.',6,'mqcVariable%getType()',mqcVariable%getType()) +! + if(PRESENT(mqcVariableOut)) then + mqcVariableOut = mqcVariable + do i=1,SIZE(mqcVariableOut%characterArray) + call String_Change_Case_Intrinsic( & + mqcVariableOut%characterArray(i),upperLower) + endDo + else + do i=1,SIZE(mqcVariable%characterArray) + call String_Change_Case_Intrinsic( & + mqcVariable%characterArray(i),upperLower) + endDo + endIf +! + return + end subroutine MQC_Variable_Change_Case + + ! !---------------------------------------------------------------- ! | @@ -887,7 +1195,7 @@ Subroutine MQC_Print_mqcVariable(mqcVariable,iOut,header, & ! ! ! L. M. Thompson, 2016. -! H. P. Hratchian, 2017, 2020. +! H. P. Hratchian, 2017, 2020, 2026. ! ! ! Variable Declarations. @@ -934,6 +1242,23 @@ Subroutine MQC_Print_mqcVariable(mqcVariable,iOut,header, & call mqc_print_scalar(mqcVariable%integerArray(1),myIOut, & Blank_At_Top=myBlankAtTop,Blank_At_Bottom=myBlankAtBottom) endIf + case('CHARACTER') + if(PRESENT(header).and.PRESENT(formatString)) then + call mqc_print_scalar(mqcVariable%characterArray(1),myIOut, & + header,Blank_At_Top=myBlankAtTop, & + Blank_At_Bottom=myBlankAtBottom,formatStr=formatString) + elseIf(PRESENT(header)) then + call mqc_print_scalar(mqcVariable%characterArray(1),myIOut, & + header,Blank_At_Top=myBlankAtTop, & + Blank_At_Bottom=myBlankAtBottom) + elseIf(PRESENT(formatString)) then + call mqc_print_scalar(mqcVariable%characterArray(1),myIOut, & + Blank_At_Top=myBlankAtTop,Blank_At_Bottom=myBlankAtBottom, & + formatStr=formatString) + else + call mqc_print_scalar(mqcVariable%characterArray(1),myIOut, & + Blank_At_Top=myBlankAtTop,Blank_At_Bottom=myBlankAtBottom) + endIf case default call mqc_error_a('MQC variable print requested for unknown type.', 6, & 'mqcVariable%getType()', mqcVariable%getType()) @@ -958,6 +1283,23 @@ Subroutine MQC_Print_mqcVariable(mqcVariable,iOut,header, & call mqc_print_vector(mqcVariable%integerArray(:),myIOut, & Blank_At_Top=myBlankAtTop,Blank_At_Bottom=myBlankAtBottom) endIf + case('CHARACTER') + if(PRESENT(header).and.PRESENT(formatString)) then + call mqc_print_vector(mqcVariable%characterArray(:),myIOut, & + header,Blank_At_Top=myBlankAtTop, & + Blank_At_Bottom=myBlankAtBottom,formatStr=formatString) + elseIf(PRESENT(header)) then + call mqc_print_vector(mqcVariable%characterArray(:),myIOut, & + header,Blank_At_Top=myBlankAtTop, & + Blank_At_Bottom=myBlankAtBottom) + elseIf(PRESENT(formatString)) then + call mqc_print_vector(mqcVariable%characterArray(:),myIOut, & + Blank_At_Top=myBlankAtTop,Blank_At_Bottom=myBlankAtBottom, & + formatStr=formatString) + else + call mqc_print_vector(mqcVariable%characterArray(:),myIOut, & + Blank_At_Top=myBlankAtTop,Blank_At_Bottom=myBlankAtBottom) + endIf case default call mqc_error_a('MQC variable print requested for unknown type.', 6, & 'mqcVariable%getType()', mqcVariable%getType() ) @@ -1035,7 +1377,7 @@ function MQC_Variable_get_MQC(mqcVariable,arrayElement) result(valueMQC) ! array element is sent in dummy argument . ! ! -! H. P. Hratchian, 2018. +! H. P. Hratchian, 2018, 2026. ! ! ! Variable Declarations. @@ -1063,6 +1405,8 @@ function MQC_Variable_get_MQC(mqcVariable,arrayElement) result(valueMQC) valueMQC = mqcVariable%realArray(k) case('INTEGER') valueMQC = mqcVariable%integerArray(k) + case('CHARACTER') + valueMQC = mqcVariable%characterArray(k) case default call mqc_error_a('MQC_Variable_Put: Unknown MQC variable type.', 6, & 'TRIM(MQC_Variable_getType(mqcVariable))', TRIM(MQC_Variable_getType(mqcVariable)) ) @@ -1249,7 +1593,7 @@ subroutine MQC_Variable_put_MQC(mqcVariable,valueMQC,arrayElement) ! . ! ! -! H. P. Hratchian, 2017. +! H. P. Hratchian, 2017, 2026. ! ! ! Variable Declarations. @@ -1279,6 +1623,12 @@ subroutine MQC_Variable_put_MQC(mqcVariable,valueMQC,arrayElement) mqcVariable%realArray(k) = float(valueMQC) case('INTEGER') mqcVariable%integerArray(k) = Int(valueMQC) + case('CHARACTER') + if(TRIM(valueMQC%getType()).ne.'CHARACTER') & + call mqc_error_a('MQC_Variable_Put: A character destination '// & + 'requires a character value.',6,'valueMQC%getType()', & + valueMQC%getType()) + mqcVariable%characterArray(k) = valueMQC%characterArray(1) case default call mqc_error_a('MQC_Variable_Put: Unknown MQC variable type.', 6, & 'TRIM(MQC_Variable_getType(mqcVariable))', TRIM(MQC_Variable_getType(mqcVariable)) ) @@ -1381,6 +1731,47 @@ subroutine MQC_Variable_put_intrinsicReal(mqcVariable,valueReal,arrayElement) end subroutine MQC_Variable_put_intrinsicReal +! +!PROCEDURE MQC_Variable_put_intrinsicCharacter + subroutine MQC_Variable_put_intrinsicCharacter(mqcVariable, & + valueCharacter,arrayElement) +! +! This subroutine puts an intrinsic character value into a specified +! element of a character MQC_Variable array. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(inOut)::mqcVariable + character(len=*),intent(in)::valueCharacter + integer(kind=int64),dimension(:),intent(in)::arrayElement +! + integer(kind=int64)::k +! +! + if(.not.mqcVariable%initialized) & + call mqc_error('Cannot use MQC_Variable_Put with an uninitialized '// & + 'MQC variable.',6) + if(TRIM(mqcVariable%getType()).ne.'CHARACTER') & + call mqc_error_a('MQC_Variable_Put: Character values require a '// & + 'character MQC_Variable.',6,'mqcVariable%getType()', & + mqcVariable%getType()) + if(mqcVariable%rank.ne.SIZE(arrayElement)) & + call mqc_error_i('MQC_Variable_Put: Rank does not match the number '// & + 'of array indices.',6,'mqcVariable%rank',mqcVariable%rank, & + 'SIZE(arrayElement)',SIZE(arrayElement)) + k = MQC_Variable_getArrayPosition(mqcVariable,arrayElement) + if(k.gt.MQC_Variable_getLength(mqcVariable)) & + call mqc_error_i('MQC_Variable_Put: Invalid array index.',6, & + 'k',k,'MQC_Variable_getLength(mqcVariable)', & + MQC_Variable_getLength(mqcVariable)) + mqcVariable%characterArray(k) = valueCharacter +! + return + end subroutine MQC_Variable_put_intrinsicCharacter + + ! !PROCEDURE MQC_Variable_clear_general subroutine MQC_Variable_clear_general(mqcVariable,valueInteger, & @@ -1484,7 +1875,7 @@ subroutine MQC_Variable_clear_mqc(mqcVariable,valueMQC,dimensions) ! as a scalar. ! ! -! H. P. Hratchian, 2017. +! H. P. Hratchian, 2017, 2026. ! ! ! Variable Declarations. @@ -1514,6 +1905,14 @@ subroutine MQC_Variable_clear_mqc(mqcVariable,valueMQC,dimensions) call MQC_Variable_clear_general(mqcVariable, & valueInteger=valueMQC%integerArray(1)) endIf + case('CHARACTER') + if(PRESENT(dimensions)) then + call MQC_Variable_clear_character(mqcVariable, & + valueMQC%characterArray(1),dimensions) + else + call MQC_Variable_clear_character(mqcVariable, & + valueMQC%characterArray(1)) + endIf case default call mqc_error_A( & 'MQC_Variable_clear: Unknown type of MQC variable sent.', 6, & @@ -1598,6 +1997,39 @@ subroutine MQC_Variable_clear_real(mqcVariable,valueReal,dimensions) end subroutine MQC_Variable_clear_real +! +!PROCEDURE MQC_Variable_clear_character + subroutine MQC_Variable_clear_character(mqcVariable,valueCharacter, & + dimensions) +! +! This routine initializes a character MQC_Variable and fills every +! element with valueCharacter. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(inOut)::mqcVariable + character(len=*),intent(in)::valueCharacter + integer(kind=int64),dimension(:),intent(in),optional::dimensions +! + integer(kind=int64)::myRank +! +! + if(PRESENT(dimensions)) then + myRank = SIZE(dimensions) + call mqcVariable%init('CHARACTER',dimensions=dimensions,rank=myRank, & + storageFormat='FULL',characterLength=LEN(valueCharacter)) + else + call mqcVariable%init('CHARACTER', & + characterLength=LEN(valueCharacter)) + endIf + mqcVariable%characterArray = valueCharacter +! + return + end subroutine MQC_Variable_clear_character + + ! !PROCEDURE MQC_Variable_mqc2mqc_subroutine subroutine MQC_Variable_mqc2mqc_subroutine(mqcVariable,mqcIn) @@ -1608,7 +2040,7 @@ subroutine MQC_Variable_mqc2mqc_subroutine(mqcVariable,mqcIn) ! that calls it. ! ! -! H. P. Hratchian, 2017. +! H. P. Hratchian, 2017, 2026. ! ! ! Variable Declarations. @@ -1620,7 +2052,11 @@ subroutine MQC_Variable_mqc2mqc_subroutine(mqcVariable,mqcIn) ! Do the work... ! if(Allocated(mqcVariable%realArray)) DeAllocate(mqcVariable%realArray) + if(Allocated(mqcVariable%complexArray)) & + DeAllocate(mqcVariable%complexArray) if(Allocated(mqcVariable%integerArray)) DeAllocate(mqcVariable%integerArray) + if(Allocated(mqcVariable%characterArray)) & + DeAllocate(mqcVariable%characterArray) mqcVariable%rank = mqcIn%rank mqcVariable%dataType = mqcIn%dataType mqcVariable%storageFormat = mqcIn%storageFormat @@ -1632,6 +2068,10 @@ subroutine MQC_Variable_mqc2mqc_subroutine(mqcVariable,mqcIn) case('INTEGER') Allocate(mqcVariable%integerArray(SIZE(mqcIn%integerArray(:)))) mqcVariable%integerArray = mqcIn%integerArray + case('CHARACTER') + Allocate(character(len=LEN(mqcIn%characterArray)):: & + mqcVariable%characterArray(SIZE(mqcIn%characterArray))) + mqcVariable%characterArray = mqcIn%characterArray case default call mqc_error_A('MQC_Variable_mqc2mqc: Confused by data type.', & 6,'TRIM(mqcIn%getType())', TRIM(mqcIn%getType()) ) @@ -1649,16 +2089,17 @@ function MQC_Variable_mqc2mqc(mqcVariableIn) result(mqcVariableOut) ! This function sets a new MQC_Variable equal to the one sent here. ! ! -! H. P. Hratchian, 2018. +! H. P. Hratchian, 2018, 2026. ! ! ! Variable Declarations. + implicit none class(MQC_Variable),intent(in)::mqcVariableIn type(MQC_Variable)::mqcVariableOut ! ! ! Call Routine MQC_Variable_mqc2mqc_subroutine... - call MQC_Variable_mqc2mqc_subroutine(mqcVariableIn,mqcVariableOut) + call MQC_Variable_mqc2mqc_subroutine(mqcVariableOut,mqcVariableIn) ! return end function MQC_Variable_mqc2mqc @@ -1667,15 +2108,16 @@ end function MQC_Variable_mqc2mqc ! !PROCEDURE MQC_Variable_setVal subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & - scalarRealIn,arrayIntegerIn,arrayRealIn,dimensions,DEBUGPRINT) + scalarRealIn,arrayIntegerIn,arrayRealIn,dimensions,DEBUGPRINT, & + scalarCharacterIn,arrayCharacterIn) ! ! This subroutine is used to set one or more values in the packed storage -! array of MQC_Variable dummy argument to an scalar or array -! given by one of , , , or -! . +! array of MQC_Variable dummy argument to a scalar or array +! given by one of the intrinsic character, real, or integer input +! arguments. ! ! -! H. P. Hratchian, 2017. +! H. P. Hratchian, 2017, 2026. ! ! ! Variable Declarations. @@ -1687,10 +2129,13 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & real(kind=real64),dimension(:),optional::arrayRealIn integer(kind=int64),dimension(:),optional::dimensions logical,optional::DEBUGPRINT + character(len=*),intent(in),optional::scalarCharacterIn + character(len=*),dimension(:),intent(in),optional::arrayCharacterIn ! integer(kind=int64)::i,nInputs,myRank integer(kind=int64),dimension(:),allocatable::myDimensions - logical::DEBUG,fillInteger,fillReal,fillScalar,fillArray + integer(kind=int64)::myCharacterLength + logical::DEBUG,fillInteger,fillReal,fillCharacter,fillScalar,fillArray character(len=64)::myDataType ! ! @@ -1712,8 +2157,12 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & write(*,*)' INPUT ARGUMENTS:' write(*,*)' PRESENT(scalarIntegerIn) = ',PRESENT(scalarIntegerIn) write(*,*)' PRESENT(scalarRealIn) = ',PRESENT(scalarRealIn) + write(*,*)' PRESENT(scalarCharacterIn) = ', & + PRESENT(scalarCharacterIn) write(*,*)' PRESENT(arrayIntegerIn) = ',PRESENT(arrayIntegerIn) write(*,*)' PRESENT(arrayRealIn) = ',PRESENT(arrayRealIn) + write(*,*)' PRESENT(arrayCharacterIn) = ', & + PRESENT(arrayCharacterIn) write(*,*)' PRESENT(dimensions) = ',PRESENT(dimensions) write(*,*) flush(MQC_Algebra2_IOut) @@ -1721,8 +2170,10 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & nInputs = 0 if(Present(scalarIntegerIn)) nInputs = nInputs+1 if(Present(scalarRealIn)) nInputs = nInputs+1 + if(Present(scalarCharacterIn)) nInputs = nInputs+1 if(Present(arrayIntegerIn)) nInputs = nInputs+1 if(Present(arrayRealIn)) nInputs = nInputs+1 + if(Present(arrayCharacterIn)) nInputs = nInputs+1 if(nInputs.gt.1) & call MQC_Error_I('MQC_Variable_setVal Error: Multiple input values sent.', 6, & "nInputs", nInputs ) @@ -1731,11 +2182,16 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & "nInputs", nInputs ) fillInteger = Present(scalarIntegerIn).or.Present(arrayIntegerIn) fillReal = Present(scalarRealIn).or.Present(arrayRealIn) - fillScalar = Present(scalarIntegerIn).or.Present(scalarRealIn) - fillArray = Present(arrayIntegerIn).or.Present(arrayRealIn) + fillCharacter = Present(scalarCharacterIn).or. & + Present(arrayCharacterIn) + fillScalar = Present(scalarIntegerIn).or.Present(scalarRealIn).or. & + Present(scalarCharacterIn) + fillArray = Present(arrayIntegerIn).or.Present(arrayRealIn).or. & + Present(arrayCharacterIn) if(DEBUG) then write(*,*)' fillInteger=',fillInteger write(*,*)' fillReal =',fillReal + write(*,*)' fillCharacter=',fillCharacter write(*,*)' fillScalar =',fillScalar write(*,*)' fillArray =',fillArray flush(MQC_Algebra2_IOut) @@ -1747,11 +2203,14 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & myDataType = 'INTEGER' elseIf(fillReal) then myDataType = 'REAL' + elseIf(fillCharacter) then + myDataType = 'CHARACTER' else call MQC_Error_L( & 'MQC_Variable_setVal: Confused setting myDataType.', 6, & 'fillInteger', fillInteger, & - 'fillReal', fillReal ) + 'fillReal', fillReal, & + 'fillCharacter',fillCharacter) endIf if(DEBUG) write(*,*)' myDataType = ',TRIM(myDataType) if(PRESENT(dimensions)) then @@ -1775,6 +2234,8 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & myDimensions(1) = SIZE(arrayIntegerIn) elseIf(fillReal) then myDimensions(1) = SIZE(arrayRealIn) + elseIf(fillCharacter) then + myDimensions(1) = SIZE(arrayCharacterIn) else call mqc_error_l( & 'MQC_Variable_setVal: Confused setting myDimensions.', 6, & @@ -1794,11 +2255,29 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & ! Initialize mqcVariable and then set the value appropriately. ! if(DEBUG) write(*,*)' Calling Init...' + if(fillCharacter) then + if(fillScalar) then + myCharacterLength = LEN(scalarCharacterIn) + else + myCharacterLength = LEN(arrayCharacterIn) + endIf + endIf if(myRank.eq.0) then - call MQC_Variable_initialize(mqcVariable,myDataType,debug=DEBUG) + if(fillCharacter) then + call MQC_Variable_initialize(mqcVariable,myDataType,debug=DEBUG, & + characterLength=myCharacterLength) + else + call MQC_Variable_initialize(mqcVariable,myDataType,debug=DEBUG) + endIf else - call MQC_Variable_initialize(mqcVariable,myDataType,myDimensions, & - myRank,'FULL',debug=DEBUG) + if(fillCharacter) then + call MQC_Variable_initialize(mqcVariable,myDataType,myDimensions, & + myRank,'FULL',debug=DEBUG, & + characterLength=myCharacterLength) + else + call MQC_Variable_initialize(mqcVariable,myDataType,myDimensions, & + myRank,'FULL',debug=DEBUG) + endIf endIf if(DEBUG) then write(*,*)' Back from init.' @@ -1806,8 +2285,13 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & write(*,*)' dimensions = ',mqcVariable%dimensions write(*,*)' ALLOCATED(realArray) ? = ',ALLOCATED(mqcVariable%realArray) write(*,*)' ALLOCATED(integerArray) ? = ',ALLOCATED(mqcVariable%integerArray) + write(*,*)' ALLOCATED(characterArray) ? = ', & + ALLOCATED(mqcVariable%characterArray) if(Allocated(mqcVariable%realArray)) write(*,*)' SIZE(realArray) = ',SIZE(mqcVariable%realArray) if(Allocated(mqcVariable%integerArray)) write(*,*)' SIZE(integerArray) = ',SIZE(mqcVariable%integerArray) + if(Allocated(mqcVariable%characterArray)) & + write(*,*)' SIZE(characterArray) = ', & + SIZE(mqcVariable%characterArray) flush(MQC_Algebra2_IOut) endIf @@ -1815,6 +2299,7 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & write(*,*) write(*,*)' fillScalar = ',fillScalar write(*,*)' fillReal = ',fillReal + write(*,*)' fillCharacter = ',fillCharacter write(*,*) endIf @@ -1823,12 +2308,15 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & mqcVariable%integerArray(1) = scalarIntegerIn elseIf(fillReal) then mqcVariable%realArray(1) = scalarRealIn + elseIf(fillCharacter) then + mqcVariable%characterArray(1) = scalarCharacterIn else call MQC_Error_L( & 'MQC_Variable_setVal: Confused filling scalar value.', 6, & 'fillScalar', fillScalar, & 'fillInteger', fillInteger, & - 'fillReal', fillReal ) + 'fillReal', fillReal, & + 'fillCharacter',fillCharacter) endIf elseIf(fillArray) then if(fillInteger) then @@ -1846,12 +2334,15 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & write(*,*)' mqcVariable%realArray(1) = ',mqcVariable%realArray(1) write(*,*) endIf + elseIf(fillCharacter) then + mqcVariable%characterArray = arrayCharacterIn else call MQC_Error_L( & 'MQC_Variable_setVal: Confused filling array values.', 6, & 'fillArray', fillArray, & 'fillInteger', fillInteger, & - 'fillReal', fillReal ) + 'fillReal', fillReal, & + 'fillCharacter',fillCharacter) endIf endIf ! @@ -1866,6 +2357,29 @@ subroutine MQC_Variable_setVal(mqcVariable,scalarIntegerIn, & end subroutine MQC_Variable_setVal +! +!PROCEDURE MQC_Variable_setVal_intrinsicScalar2mqcScalar_character + subroutine MQC_Variable_setVal_intrinsicScalar2mqcScalar_character( & + mqcVariable,intrinsicIn) +! +! This subroutine sets an MQC_Variable scalar equal to an intrinsic +! character scalar. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(inOut)::mqcVariable + character(len=*),intent(in)::intrinsicIn +! +! + call MQC_Variable_setVal(mqcVariable, & + scalarCharacterIn=intrinsicIn) +! + return + end subroutine MQC_Variable_setVal_intrinsicScalar2mqcScalar_character + + ! !PROCEDURE MQC_Variable_setVal_intrinsicScalar2mqcScalar_integer subroutine MQC_Variable_setVal_intrinsicScalar2mqcScalar_integer(mqcVariable,intrinsicIn) @@ -1916,6 +2430,28 @@ subroutine MQC_Variable_setVal_intrinsicScalar2mqcScalar_real(mqcVariable,intrin end subroutine MQC_Variable_setVal_intrinsicScalar2mqcScalar_real +! +!PROCEDURE MQC_Variable_setVal_intrinsicVector2mqcVector_character + subroutine MQC_Variable_setVal_intrinsicVector2mqcVector_character( & + mqcVariable,intrinsicIn) +! +! This subroutine sets an MQC_Variable vector equal to an intrinsic +! character vector. +! +! H. P. Hratchian, 2026. +! +! + implicit none + class(MQC_Variable),intent(inOut)::mqcVariable + character(len=*),dimension(:),intent(in)::intrinsicIn +! +! + call MQC_Variable_setVal(mqcVariable,arrayCharacterIn=intrinsicIn) +! + return + end subroutine MQC_Variable_setVal_intrinsicVector2mqcVector_character + + ! !PROCEDURE MQC_Variable_setVal_intrinsicVector2mqcVector_integer subroutine MQC_Variable_setVal_intrinsicVector2mqcVector_integer(mqcVariable,intrinsicIn) @@ -2084,6 +2620,36 @@ subroutine MQC_Variable_setVal_intrinsicRank42mqcRank4_real(mqcVariable,intrinsi end subroutine MQC_Variable_setVal_intrinsicRank42mqcRank4_real +! +!PROCEDURE MQC_Variable_mqc2intrinsicCharacterScalar + subroutine MQC_Variable_mqc2intrinsicCharacterScalar(intrinsicOut, & + mqcVariable) +! +! This routine assigns a character MQC_Variable scalar to an intrinsic +! character scalar. Normal Fortran padding or truncation applies to the +! destination. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),intent(out)::intrinsicOut + class(MQC_Variable),intent(in)::mqcVariable +! +! + if(RANK(mqcVariable).ne.0) & + call mqc_error_i('Attempt to convert an MQC_Variable array to an '// & + 'intrinsic character scalar.',6,'RANK(mqcVariable)', & + RANK(mqcVariable)) + if(TRIM(mqcVariable%getType()).ne.'CHARACTER') & + call mqc_error_a('Character assignment requires a character '// & + 'MQC_Variable.',6,'mqcVariable%getType()',mqcVariable%getType()) + intrinsicOut = mqcVariable%characterArray(1) +! + return + end subroutine MQC_Variable_mqc2intrinsicCharacterScalar + + ! !PROCEDURE MQC_Variable_mqc2intrinsicIntegerScalar subroutine MQC_Variable_mqc2intrinsicIntegerScalar(intrinsicOut,mqcVariable) @@ -2164,7 +2730,7 @@ subroutine MQC_Variable_mqc2intrinsicInteger1Array(intrinsicOut,mqcVariable) ! to an (input) MQC Variable vector. ! ! -! H. P. Hratchian, 2022. +! H. P. Hratchian, 2022, 2026. ! ! ! Variable Declarations. @@ -2179,7 +2745,14 @@ subroutine MQC_Variable_mqc2intrinsicInteger1Array(intrinsicOut,mqcVariable) call mqc_error_I('Attemp to convert MQC_Variable array to '// & 'intrinsic SCALAR not allowed.',6,'Rank(mqcVariable)', & Rank(mqcVariable)) - allocate(intrinsicOut(SIZE(mqcVariable,1))) + if(ALLOCATED(intrinsicOut)) then + if(SIZE(intrinsicOut).ne.SIZE(mqcVariable,1)) then + DeAllocate(intrinsicOut) + Allocate(intrinsicOut(SIZE(mqcVariable,1))) + endIf + else + Allocate(intrinsicOut(SIZE(mqcVariable,1))) + endIf select case(MQC_Variable_getTypeCode(mqcVariable)) case(2) call mqc_error('MQC_Variable_mqc2intrinsicInteger1Array: '// & @@ -2244,6 +2817,37 @@ subroutine MQC_Variable_mqc2intrinsicReal1Array(intrinsicOut,mqcVariable) end subroutine MQC_Variable_mqc2intrinsicReal1Array +! +!PROCEDURE MQC_Variable_mqc2intrinsicCharacter1Array + subroutine MQC_Variable_mqc2intrinsicCharacter1Array(intrinsicOut, & + mqcVariable) +! +! This routine assigns a character MQC_Variable vector to an allocatable +! intrinsic character vector. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=:),dimension(:),allocatable,intent(out)::intrinsicOut + class(MQC_Variable),intent(in)::mqcVariable +! +! + if(RANK(mqcVariable).ne.1) & + call mqc_error_i('Attempt to convert a non-vector MQC_Variable to '// & + 'an intrinsic character vector.',6,'RANK(mqcVariable)', & + RANK(mqcVariable)) + if(TRIM(mqcVariable%getType()).ne.'CHARACTER') & + call mqc_error_a('Character assignment requires a character '// & + 'MQC_Variable.',6,'mqcVariable%getType()',mqcVariable%getType()) + allocate(character(len=LEN(mqcVariable)):: & + intrinsicOut(SIZE(mqcVariable))) + intrinsicOut = mqcVariable%characterArray +! + return + end subroutine MQC_Variable_mqc2intrinsicCharacter1Array + + ! !PROCEDURE MQC_Variable_mqc2intrinsicInteger2Array subroutine MQC_Variable_mqc2intrinsicInteger2Array(intrinsicOut,mqcVariable) @@ -2372,6 +2976,28 @@ subroutine MQC_Variable_mqc2intrinsicReal4Array(intrinsicOut,mqcVariable) end subroutine MQC_Variable_mqc2intrinsicReal4Array +! +!PROCEDURE MQC_Variable_from_intrinsicCharacter + function MQC_Variable_from_intrinsicCharacter(intrinsicIn) & + result(mqcVariable) +! +! This function converts an intrinsic character scalar to an MQC_Variable. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),intent(in)::intrinsicIn + type(MQC_Variable)::mqcVariable +! +! + call MQC_Variable_setVal(mqcVariable, & + scalarCharacterIn=intrinsicIn) +! + return + end function MQC_Variable_from_intrinsicCharacter + + ! !PROCEDURE MQC_Variable_from_intrinsicInteger function MQC_Variable_from_intrinsicInteger(intrinsicIn) result(mqcVariable) diff --git a/src/mqc_binary.F03 b/src/mqc_binary.F03 index ea9dadb7..25aa3dd5 100644 --- a/src/mqc_binary.F03 +++ b/src/mqc_binary.F03 @@ -10,8 +10,8 @@ module MQC_Binary ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/src/mqc_datastructures.F03 b/src/mqc_datastructures.F03 index be36eca7..5920dc4e 100644 --- a/src/mqc_datastructures.F03 +++ b/src/mqc_datastructures.F03 @@ -10,8 +10,8 @@ Module MQC_DataStructures ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 8c9a053f..4d4a8152 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -38,8 +38,8 @@ Module MQC_EST ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/src/mqc_files.F03 b/src/mqc_files.F03 index 87a1580f..6b4a8c88 100644 --- a/src/mqc_files.F03 +++ b/src/mqc_files.F03 @@ -10,8 +10,8 @@ Module MQC_Files ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/src/mqc_gaussian.F03 b/src/mqc_gaussian.F03 index 8a55b5a8..20185617 100644 --- a/src/mqc_gaussian.F03 +++ b/src/mqc_gaussian.F03 @@ -10,8 +10,8 @@ Module MQC_Gaussian ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** @@ -1134,7 +1134,7 @@ subroutine MQC_Gaussian_Unformatted_Matrix_Read_Array(fileinfo, & integer::iout=6 ! ! Temporary local variables used when calling the gauopen routines. - integer::IVers,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5,NRI,LR + integer::IVers,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5,NRI,LR,TypeA character(len=64)::cBuffer,tmpLabel logical::EOF,ASym ! @@ -1155,7 +1155,7 @@ subroutine MQC_Gaussian_Unformatted_Matrix_Read_Array(fileinfo, & 1000 format(' MQC_Gaussian_Read is looking for array ',A, & ' in matrix file.') 1010 format(' Label ',A48,' NI=',I2,' NR=',I2,' NRI=',I1,' NTot=', & - I8,' LenBuf=',I8,' N=',5I6,' ASym=',L1,' LR=',I5) + I8,' LenBuf=',I8,' N=',5I6,' TypeA=',I8,' ASym=',L1,' LR=',I5) 1020 Format( " " )! 1040 Format( A, I15 ) 1050 Format( 2A ) @@ -1224,11 +1224,12 @@ subroutine MQC_Gaussian_Unformatted_Matrix_Read_Array(fileinfo, & found = .false. outerLoop:do i = 1,2 EOF = .false. - Call Rd_Labl(fileinfo%UnitNumber,IVers,cBuffer,NI,NR,NTot,LenBuf, & - N1,N2,N3,N4,N5,ASym,NRI,EOF) + Call Rd_Labl_TypeA(fileinfo%UnitNumber,IVers,cBuffer,NI,NR,NTot, & + LenBuf,N1,N2,N3,N4,N5,TypeA,NRI,EOF) + ASym = TypeA.ne.0 LR = LenArr(N1,N2,N3,N4,N5) if(DEBUG) write(IOut,1010) TRIM(cBuffer),NI,NR,NRI,NTot,LenBuf, & - N1,N2,N3,N4,N5,ASym,LR + N1,N2,N3,N4,N5,TypeA,ASym,LR do while(.not.EOF) call String_Change_Case(cBuffer,'u') if(TRIM(tmpLabel) == TRIM(cBuffer)) then @@ -1254,12 +1255,12 @@ subroutine MQC_Gaussian_Unformatted_Matrix_Read_Array(fileinfo, & write(IOut,*) & ' MQC_Gaussian_Unformatted_Matrix_Array_Type = ', & MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1, & - N2,N3,N4,N5,NRI,ASym) + N2,N3,N4,N5,NRI,ASym,TypeA) write(IOut,*) & ' MQC_Gaussian_Unformatted_Matrix_Array_Type = ', & - MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym) + MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym,TypeA) endIf - select case(MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym)) + select case(MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym,TypeA)) case('INTEGER-VECTOR') allocate(integerTmp(LR)) call Rd_IBuf(fileinfo%unitNumber,NTot,LenBuf,integerTmp) @@ -1468,8 +1469,8 @@ subroutine MQC_Gaussian_Unformatted_Matrix_Read_Array(fileinfo, & write(*,1020) call mqc_error_a('No general way to load mixed types as of yet & & We are doing it case-by-case at the moment and this does not match.', 6, & - 'MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym)', & - MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym) ) + 'MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym,TypeA)', & + MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym,TypeA) ) case('2ERIS-SYMSYMR4TENSOR') if(Present(r4TensorOut)) then if(NRI.eq.1) then @@ -1549,22 +1550,23 @@ subroutine MQC_Gaussian_Unformatted_Matrix_Read_Array(fileinfo, & deallocate(arrayTmp) ! case default - write(*,1050)' Matrix type: ',Trim(MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym)) + write(*,1050)' Matrix type: ',Trim(MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym,TypeA)) call mqc_error_A('Found strange matrix type in Gaussian matrix read routine.', 6, & - 'MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym)', & - MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym) ) + 'MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym,TypeA)', & + MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym,TypeA) ) end select found = .true. exit outerLoop elseIf(NTot.gt.0) then Call Rd_Skip(fileinfo%UnitNumber,NTot,LenBuf) endIf - Call Rd_Labl(fileinfo%UnitNumber,IVers,cBuffer,NI,NR,NTot,LenBuf, & - N1,N2,N3,N4,N5,ASym,NRI,EOF) + Call Rd_Labl_TypeA(fileinfo%UnitNumber,IVers,cBuffer,NI,NR,NTot, & + LenBuf,N1,N2,N3,N4,N5,TypeA,NRI,EOF) + ASym = TypeA.ne.0 LR = LenArr(N1,N2,N3,N4,N5) EOF = EOF.or.cBuffer.eq.'END' if(DEBUG) write(IOut,1010) TRIM(cBuffer),NI,NR,NRI,NTot,LenBuf, & - N1,N2,N3,N4,N5,ASym,LR + N1,N2,N3,N4,N5,TypeA,ASym,LR endDo if(i==1) then my_filename = TRIM(fileinfo%filename) @@ -5857,7 +5859,8 @@ end Function MQC_Gaussian_Unformatted_Matrix_Get_Value_Real !===================================================================== ! !PROCEDURE MQC_Gaussian_Unformatted_Matrix_Array_Type - Function MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASym) + Function MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2, & + N3,N4,N5,NRI,ASym,TypeA) ! ! This function returns a character string indicating the type of array ! found in a Gaussian matrix file. This is done using NI, NR, N1, N2, N3, @@ -5873,18 +5876,20 @@ Function MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASy ! "SYMMATRIXN" Multiple (N) symmetric/hermitian matrix. ! "ASYMMATRIXN" Multiple (N) asymmetric/antihermitian matrix. ! +! Character records are identified by NI=1, NR=0, and positive TypeA/IType. +! ! If the input flags do not uniquely identify a known array type, then this ! function returns "UNKNOWN". ! ! -! H. P. Hratchian, 2017. +! H. P. Hratchian, 2017, 2026. ! L. M. Thompson, 2018. ! ! ! Variable Declarations. ! implicit none - integer::NI,NR,N1,N2,N3,N4,N5,NRI + integer::NI,NR,N1,N2,N3,N4,N5,NRI,TypeA logical::Asym character(len=64)::MQC_Gaussian_Unformatted_Matrix_Array_Type ! @@ -5893,6 +5898,10 @@ Function MQC_Gaussian_Unformatted_Matrix_Array_Type(NI,NR,N1,N2,N3,N4,N5,NRI,ASy ! MQC_Gaussian_Unformatted_Matrix_Array_Type = "UNKNOWN" if(NR.lt.0.or.NI.lt.0) return + if(NI.eq.1.and.NR.eq.0.and.TypeA.gt.0) then + MQC_Gaussian_Unformatted_Matrix_Array_Type = "CHARACTER" + return + endIf if(NR.gt.0.and.NI.gt.0) then MQC_Gaussian_Unformatted_Matrix_Array_Type = "MIXED" if(NR.eq.1.and.NI.eq.1) then diff --git a/src/mqc_general.F03 b/src/mqc_general.F03 index cd0b84b5..fd14788b 100644 --- a/src/mqc_general.F03 +++ b/src/mqc_general.F03 @@ -10,8 +10,8 @@ Module MQC_General ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** @@ -82,9 +82,11 @@ Module MQC_General ! ! interface mqc_print + module procedure MQC_Print_Scalar_Character module procedure MQC_Print_Scalar_Integer module procedure MQC_Print_Scalar_Real module procedure MQC_Print_Scalar_Complex + module procedure MQC_Print_Vector_Array_Character module procedure MQC_Print_Vector_Array_Integer module procedure MQC_Print_Vector_Array_Real module procedure MQC_Print_Vector_Array_Complex @@ -98,12 +100,14 @@ Module MQC_General end interface ! interface mqc_print_scalar + module procedure MQC_Print_Scalar_Character module procedure MQC_Print_Scalar_Integer module procedure MQC_Print_Scalar_Real module procedure MQC_Print_Scalar_Complex end interface ! interface mqc_print_vector + module procedure MQC_Print_Vector_Array_Character module procedure MQC_Print_Vector_Array_Integer module procedure MQC_Print_Vector_Array_Real module procedure MQC_Print_Vector_Array_Complex @@ -137,6 +141,25 @@ Module MQC_General module procedure real2character module procedure complex2character end interface +! + interface mqc_adjustl + module procedure mqc_adjustl_character_scalar + module procedure mqc_adjustl_character_vector + end interface +! + interface mqc_adjustr + module procedure mqc_adjustr_character_scalar + module procedure mqc_adjustr_character_vector + end interface +! + interface mqc_len_trim + module procedure mqc_len_trim_character_scalar + module procedure mqc_len_trim_character_vector + end interface +! + interface mqc_trim + module procedure mqc_trim_character_scalar + end interface ! interface sort module procedure mqc_bubbleSort_integer @@ -182,18 +205,18 @@ subroutine mqc_version(major,minor,revision,versionString) ! This subroutine returns the current MQC version number. The full MQC ! version number is comprised of three components: major.minor.revision. The ! major version indicated is given by the last two digits of the versioning -! year; the minor label is two digits indicating a versioning month; and the -! last digit gives a revision number. +! year; the minor label indicates a versioning month; and the final +! component gives a revision number. ! ! implicit none integer,OPTIONAL,intent(out)::major,minor,revision character(len=*),OPTIONAL,intent(out)::versionString ! - if(PRESENT(major)) major = 25 - if(PRESENT(minor)) minor = 11 - if(PRESENT(revision)) revision = 2 - if(PRESENT(versionString)) versionString = '25.11.2' + if(PRESENT(major)) major = 26 + if(PRESENT(minor)) minor = 7 + if(PRESENT(revision)) revision = 0 + if(PRESENT(versionString)) versionString = '26.7.0' ! return end subroutine mqc_version @@ -715,6 +738,48 @@ End Subroutine mqc_get_command_argument_real ! | !---------------------------------------------------------------- ! +! +!PROCEDURE MQC_Print_Scalar_Character + subroutine MQC_Print_Scalar_Character(scalar,iOut,header,blank_at_top, & + blank_at_bottom,formatStr) +! +! This subroutine is used to print a character scalar. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),intent(in)::scalar + integer(kind=int64),intent(in)::iOut + character(len=*),intent(in),optional::header,formatStr + logical,intent(in),optional::blank_at_top,blank_at_bottom +! + character(len=256)::formatLine +! +! + if(PRESENT(blank_at_top)) then + if(blank_at_top) write(iOut,'(" ")') + endIf + if(PRESENT(formatStr)) then + formatLine = '(1x,A,1x,'//TRIM(formatStr)//')' + if(PRESENT(header)) then + write(iOut,TRIM(formatLine)) TRIM(header),scalar + else + write(iOut,TRIM(formatLine)) '',scalar + endIf + elseIf(PRESENT(header)) then + write(iOut,'(1x,A,1x,A)') TRIM(header),TRIM(scalar) + else + write(iOut,'(1x,A)') TRIM(scalar) + endIf + if(PRESENT(blank_at_bottom)) then + if(blank_at_bottom) write(iOut,'(" ")') + endIf +! + return + end subroutine MQC_Print_Scalar_Character + + ! !PROCEDURE MQC_Print_Scalar_Integer Subroutine MQC_Print_Scalar_Integer(scalar,iOut,Header,Blank_At_Top, & @@ -1112,6 +1177,46 @@ Subroutine MQC_Print_Matrix_Array_Logical(Array,iOut,Header,Blank_At_Top, & Return End Subroutine MQC_Print_Matrix_Array_Logical +! +!PROCEDURE MQC_Print_Vector_Array_Character + subroutine MQC_Print_Vector_Array_Character(vector,iOut,header, & + blank_at_top,blank_at_bottom,formatStr) +! +! This subroutine is used to print a character vector. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),dimension(:),intent(in)::vector + integer(kind=int64),intent(in)::iOut + character(len=*),intent(in),optional::header,formatStr + logical,intent(in),optional::blank_at_top,blank_at_bottom +! + integer(kind=int64)::i + character(len=256)::formatLine +! +! + if(PRESENT(blank_at_top)) then + if(blank_at_top) write(iOut,'(" ")') + endIf + if(PRESENT(header)) write(iOut,'(1x,A)') TRIM(header) + do i=1,SIZE(vector) + if(PRESENT(formatStr)) then + formatLine = '(1x,I7,2x,'//TRIM(formatStr)//')' + write(iOut,TRIM(formatLine)) i,vector(i) + else + write(iOut,'(1x,I7,2x,A)') i,TRIM(vector(i)) + endIf + endDo + if(PRESENT(blank_at_bottom)) then + if(blank_at_bottom) write(iOut,'(" ")') + endIf +! + return + end subroutine MQC_Print_Vector_Array_Character + + ! !PROCEDURE MQC_Print_Vector_Array_Integer subroutine MQC_Print_Vector_Array_Integer(Vector,iOut,Header,Blank_At_Top, & @@ -1446,6 +1551,152 @@ End Subroutine MQC_Print_R4Tensor_Array_Complex ! | !---------------------------------------------------------------- ! +! +!PROCEDURE mqc_adjustl_character_scalar + function mqc_adjustl_character_scalar(stringIn) result(stringOut) +! +! This function applies the Fortran ADJUSTL intrinsic to a character +! scalar while preserving its declared length. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),intent(in)::stringIn + character(len=LEN(stringIn))::stringOut +! +! + stringOut = ADJUSTL(stringIn) +! + return + end function mqc_adjustl_character_scalar + + +! +!PROCEDURE mqc_adjustl_character_vector + function mqc_adjustl_character_vector(stringIn) result(stringOut) +! +! This function applies the Fortran ADJUSTL intrinsic elementally to a +! fixed-width character vector. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),dimension(:),intent(in)::stringIn + character(len=LEN(stringIn)),dimension(SIZE(stringIn))::stringOut +! +! + stringOut = ADJUSTL(stringIn) +! + return + end function mqc_adjustl_character_vector + + +! +!PROCEDURE mqc_adjustr_character_scalar + function mqc_adjustr_character_scalar(stringIn) result(stringOut) +! +! This function applies the Fortran ADJUSTR intrinsic to a character +! scalar while preserving its declared length. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),intent(in)::stringIn + character(len=LEN(stringIn))::stringOut +! +! + stringOut = ADJUSTR(stringIn) +! + return + end function mqc_adjustr_character_scalar + + +! +!PROCEDURE mqc_adjustr_character_vector + function mqc_adjustr_character_vector(stringIn) result(stringOut) +! +! This function applies the Fortran ADJUSTR intrinsic elementally to a +! fixed-width character vector. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),dimension(:),intent(in)::stringIn + character(len=LEN(stringIn)),dimension(SIZE(stringIn))::stringOut +! +! + stringOut = ADJUSTR(stringIn) +! + return + end function mqc_adjustr_character_vector + + +! +!PROCEDURE mqc_len_trim_character_scalar + function mqc_len_trim_character_scalar(stringIn) result(lengthOut) +! +! This function applies the Fortran LEN_TRIM intrinsic to a character +! scalar and returns the result using the MQCPack integer kind. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),intent(in)::stringIn + integer(kind=int64)::lengthOut +! +! + lengthOut = LEN_TRIM(stringIn) +! + return + end function mqc_len_trim_character_scalar + + +! +!PROCEDURE mqc_len_trim_character_vector + function mqc_len_trim_character_vector(stringIn) result(lengthOut) +! +! This function applies the Fortran LEN_TRIM intrinsic elementally to a +! fixed-width character vector and returns MQCPack-kind integers. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),dimension(:),intent(in)::stringIn + integer(kind=int64),dimension(SIZE(stringIn))::lengthOut +! +! + lengthOut = LEN_TRIM(stringIn) +! + return + end function mqc_len_trim_character_vector + + +! +!PROCEDURE mqc_trim_character_scalar + function mqc_trim_character_scalar(stringIn) result(stringOut) +! +! This function applies the Fortran TRIM intrinsic to a character scalar. +! +! H. P. Hratchian, 2026. +! +! + implicit none + character(len=*),intent(in)::stringIn + character(len=:),allocatable::stringOut +! +! + stringOut = TRIM(stringIn) +! + return + end function mqc_trim_character_scalar + + ! !PROCEDURE String_Change_Case Subroutine String_Change_Case(string,upperlower,stringOut) diff --git a/src/mqc_general_lapack.F03 b/src/mqc_general_lapack.F03 index 172c2fde..1f718d97 100644 --- a/src/mqc_general_lapack.F03 +++ b/src/mqc_general_lapack.F03 @@ -9,8 +9,8 @@ ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/src/mqc_integrals.F03 b/src/mqc_integrals.F03 index 5378fce2..658c6f7b 100644 --- a/src/mqc_integrals.F03 +++ b/src/mqc_integrals.F03 @@ -10,8 +10,8 @@ module MQC_Integrals ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/src/mqc_interface.F03 b/src/mqc_interface.F03 index 9fb1714d..928ffb74 100644 --- a/src/mqc_interface.F03 +++ b/src/mqc_interface.F03 @@ -9,8 +9,8 @@ ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/src/mqc_matwrapper.F03 b/src/mqc_matwrapper.F03 index 70aa2335..0cb02eed 100644 --- a/src/mqc_matwrapper.F03 +++ b/src/mqc_matwrapper.F03 @@ -11,8 +11,8 @@ Module MQC_MatWrapper ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** @@ -477,19 +477,54 @@ Subroutine Rd_Labl(IU,IVers,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5,ASym,NRI,EOF) Integer(kind=int64),Intent(Out)::NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5,NRI Logical,Intent(Out)::ASym,EOF + Integer(kind=int64)::TypeA + + Call Rd_Labl_TypeA(IU,IVers,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3, & + N4,N5,TypeA,NRI,EOF) + ASym = TypeA.ne.0 + Return + End Subroutine Rd_Labl + +!PROCEDURE Rd_Labl_TypeA + Subroutine Rd_Labl_TypeA(IU,IVers,CBuf,NI,NR,NTot,LenBuf,N1,N2, & + N3,N4,N5,TypeA,NRI,EOF) + Implicit None + + Integer(kind=int64),Intent(In)::IU,IVers + Character(Len=64),Intent(Out)::CBuf + Integer(kind=int64),Intent(Out)::NI,NR,NTot,LenBuf,N1,N2,N3, & + N4,N5,TypeA,NRI + Logical,Intent(Out)::EOF + Integer(kind=int32)::IU_4,IVers_4 - Integer(kind=int32)::NI_4,NR_4,NTot_4,LenBuf_4,N1_4,N2_4,N3_4,N4_4,N5_4,NRI_4 + Integer(kind=int32)::NI_4,NR_4,NTot_4,LenBuf_4,N1_4,N2_4, & + N3_4,N4_4,N5_4,TypeA_4,NRI_4 + Logical::ASym + Integer(kind=int64)::LR Integer(kind=int32)::IntPrecision, Call_Test Character(Len=64)::Name Call_Test = 0 call MQC_Mat_Precision(Name, IntPrecision, Call_Test) if ( IntPrecision .eq. 4 ) then -! File requires 32-bit integers +! +! File requires 32-bit integers. +! IU_4 = IU IVers_4 = IVers - Call RdLabl4(IU_4,IVers_4,CBuf,NI_4,NR_4,NTot_4,LenBuf_4,N1_4,N2_4,N3_4,N4_4,N5_4,ASym,NRI_4,EOF) +#ifdef UCMGAUOPEN + Call RdLabl4(IU_4,IVers_4,CBuf,NI_4,NR_4,NTot_4,LenBuf_4, & + N1_4,N2_4,N3_4,N4_4,N5_4,TypeA_4,NRI_4,EOF) +#else + Call RdLabl4(IU_4,IVers_4,CBuf,NI_4,NR_4,NTot_4,LenBuf_4, & + N1_4,N2_4,N3_4,N4_4,N5_4,ASym,NRI_4,EOF) + if(ASym) then + TypeA_4 = -1 + else + TypeA_4 = 0 + endIf +#endif NI = NI_4 NR = NR_4 NTot = NTot_4 @@ -499,13 +534,41 @@ Subroutine Rd_Labl(IU,IVers,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5,ASym,NRI,EOF) N3 = N3_4 N4 = N4_4 N5 = N5_4 + TypeA = TypeA_4 NRI = NRI_4 else -! File requires 64-bit integers, so no change - Call RdLabl8(IU,IVers,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5,ASym,NRI,EOF) +! +! File requires 64-bit integers, so no change. +! +#ifdef UCMGAUOPEN + Call RdLabl8(IU,IVers,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4, & + N5,TypeA,NRI,EOF) +#else + Call RdLabl8(IU,IVers,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4, & + N5,ASym,NRI,EOF) + if(ASym) then + TypeA = -1 + else + TypeA = 0 + endIf +#endif endif +! +! UCM GauOpen stores character data in integer-sized chunks. Normalize +! character labels so TypeA is the fixed character width and NTot is the +! number of fixed-width character fields. +! +#ifdef UCMGAUOPEN + if(.not.EOF.and.NI.eq.1.and.NR.eq.0.and.TypeA.gt.0) then + LR = LenArr(N1,N2,N3,N4,N5) + if(LR.gt.0) then + TypeA = (IntPrecision*NTot)/LR + NTot = LR + endIf + endIf +#endif Return - End Subroutine Rd_Labl + End Subroutine Rd_Labl_TypeA Subroutine Rd_RInd(IU,NR,LR,NTot,LenBuf,LNZ,RArr) Implicit None @@ -617,14 +680,39 @@ Subroutine Wr_Labl(IU,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5,ASym) Logical,Intent(In)::ASym Character(Len=*),Intent(In)::CBuf + Integer(kind=int64)::TypeA + + if(ASym) then + TypeA = -1 + else + TypeA = 0 + endIf + Call Wr_Labl_TypeA(IU,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5, & + TypeA) + Return + End Subroutine Wr_Labl + +!PROCEDURE Wr_Labl_TypeA + Subroutine Wr_Labl_TypeA(IU,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5, & + TypeA) + Implicit None + + Integer(kind=int64),Intent(In)::IU,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5 + Integer(kind=int64),Intent(In)::TypeA + Character(Len=*),Intent(In)::CBuf + Integer(kind=int32)::IU_4,NI_4,NR_4,NTot_4,LenBuf_4,N1_4,N2_4,N3_4,N4_4,N5_4 + Integer(kind=int32)::TypeA_4 Integer(kind=int32)::IntPrecision, Call_Test Character(Len=64)::Name + Logical::ASym Call_Test = 0 call MQC_Mat_Precision(Name, IntPrecision, Call_Test) if ( IntPrecision .eq. 4 ) then -! File requires 32-bit integers +! +! File requires 32-bit integers. +! IU_4 = IU NI_4 = NI NR_4 = NR @@ -635,13 +723,48 @@ Subroutine Wr_Labl(IU,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5,ASym) N3_4 = N3 N4_4 = N4 N5_4 = N5 - Call WrLabl4(IU_4,CBuf,NI_4,NR_4,NTot_4,LenBuf_4,N1_4,N2_4,N3_4,N4_4,N5_4,ASym) + TypeA_4 = TypeA +#ifdef UCMGAUOPEN + if(NR_4.lt.0) then + Call MQC_Error('Wr_Labl_TypeA: NR must be nonnegative.') + endIf + if(TypeA_4.gt.0) then + write(IU_4) CBuf,NI_4,NR_4,1,NTot_4,LenBuf_4,N1_4,N2_4, & + N3_4,N4_4,N5_4,TypeA_4 + elseIf(TypeA_4.lt.0) then + write(IU_4) CBuf,NI_4,-NR_4,2,NTot_4,LenBuf_4,N1_4, & + N2_4,N3_4,N4_4,N5_4,TypeA_4 + else + write(IU_4) CBuf,NI_4,NR_4,1,NTot_4,LenBuf_4,N1_4,N2_4, & + N3_4,N4_4,N5_4,TypeA_4 + endIf +#else + ASym = TypeA.ne.0 + Call WrLabl4(IU_4,CBuf,NI_4,NR_4,NTot_4,LenBuf_4,N1_4, & + N2_4,N3_4,N4_4,N5_4,ASym) +#endif else -! File requires 64-bit integers, so no change +! +! File requires 64-bit integers, so no change. +! +#ifdef UCMGAUOPEN + if(NR.lt.0) then + Call MQC_Error('Wr_Labl_TypeA: NR must be nonnegative.') + endIf + if(TypeA.gt.0) then + write(IU) CBuf,NI,NR,1,NTot,LenBuf,N1,N2,N3,N4,N5,TypeA + elseIf(TypeA.lt.0) then + write(IU) CBuf,NI,-NR,2,NTot,LenBuf,N1,N2,N3,N4,N5,TypeA + else + write(IU) CBuf,NI,NR,1,NTot,LenBuf,N1,N2,N3,N4,N5,TypeA + endIf +#else + ASym = TypeA.ne.0 Call WrLabl8(IU,CBuf,NI,NR,NTot,LenBuf,N1,N2,N3,N4,N5,ASym) +#endif endif Return - End Subroutine Wr_Labl + End Subroutine Wr_Labl_TypeA Subroutine Wr_RBuf(IU,NTot,LenBuf,Arr) Implicit None @@ -2156,6 +2279,102 @@ Subroutine Wr_LCBuf(IU,Label,NR,LenBuf,N1,N2,N3,N4,N5,ASym,X) Return End Subroutine Wr_LCBuf +!PROCEDURE Rd_ChBuf + Subroutine Rd_ChBuf(IU,LR,LenBuf,CArr) + Implicit None + + Integer(kind=int64),Intent(In)::IU,LR,LenBuf + Character(Len=*),Intent(InOut)::CArr + + Integer(kind=int32)::IU_4,LR_4,LenBuf_4 + Integer(kind=int32)::IntPrecision, Call_Test + Character(Len=64)::Name + + Call_Test = 0 + call MQC_Mat_Precision(Name, IntPrecision, Call_Test) + if ( IntPrecision .eq. 4 ) then +! +! File requires 32-bit integers. +! + IU_4 = IU + LR_4 = LR + LenBuf_4 = LenBuf + call Rd_ChBuf4(IU_4,LR_4,LenBuf_4,CArr) + else +! +! File requires 64-bit integers, so no change. +! + call Rd_ChBuf8(IU,LR,LenBuf,CArr) + endif + Return + End Subroutine Rd_ChBuf + +!PROCEDURE Rd_ChBufI + Subroutine Rd_ChBufI(IU,LR,LenBuf,CArr,IArr) + Implicit None + + Integer(kind=int64),Intent(In)::IU,LR,LenBuf + Character(Len=*),Intent(InOut)::CArr + Integer(kind=int64),Dimension(LR),Intent(Out)::IArr + + Integer(kind=int32)::IU_4,LR_4,LenBuf_4 + Integer(kind=int32),Dimension(LR)::IArr_4 + Integer(kind=int64)::I + Integer(kind=int32)::IntPrecision, Call_Test + Character(Len=64)::Name + + Call_Test = 0 + call MQC_Mat_Precision(Name, IntPrecision, Call_Test) + if ( IntPrecision .eq. 4 ) then +! +! File requires 32-bit integers. +! + IU_4 = IU + LR_4 = LR + LenBuf_4 = LenBuf + call Rd_ChBuf4I(IU_4,LR_4,LenBuf_4,CArr,IArr_4) + do I = 1,LR + IArr(I) = IArr_4(I) + endDo + else +! +! File requires 64-bit integers, so no change. +! + call Rd_ChBuf8I(IU,LR,LenBuf,CArr,IArr) + endif + Return + End Subroutine Rd_ChBufI + +!PROCEDURE Wr_ChBuf + Subroutine Wr_ChBuf(IU,LR,LenBuf,CArr) + Implicit None + + Integer(kind=int64),Intent(In)::IU,LR,LenBuf + Character(Len=*),Intent(In)::CArr + + Integer(kind=int32)::IU_4,LR_4,LenBuf_4 + Integer(kind=int32)::IntPrecision, Call_Test + Character(Len=64)::Name + + Call_Test = 0 + call MQC_Mat_Precision(Name, IntPrecision, Call_Test) + if ( IntPrecision .eq. 4 ) then +! +! File requires 32-bit integers. +! + IU_4 = IU + LR_4 = LR + LenBuf_4 = LenBuf + call Wr_ChBuf4(IU_4,LR_4,LenBuf_4,CArr) + else +! +! File requires 64-bit integers, so no change. +! + call Wr_ChBuf8(IU,LR,LenBuf,CArr) + endif + Return + End Subroutine Wr_ChBuf + Subroutine Rd_CBuf(IU,NTot,LenBuf,Arr) Implicit None diff --git a/src/mqc_molecule.F03 b/src/mqc_molecule.F03 index fd4373c7..8ca98499 100644 --- a/src/mqc_molecule.F03 +++ b/src/mqc_molecule.F03 @@ -31,8 +31,8 @@ Module MQC_Molecule ! ** Lee M. Thompson, Xianghai Sheng, Andrew D. Mahler, Dave ** ! ** Mullally, and Hrant P. Hratchian ** ! ** ** -! ** Version 25.11.2 ** -! ** November 11, 2025 ** +! ** Version 26.7.0 ** +! ** July 13, 2026 ** ! ** ** ! ** ** ! ** Modules beloning to MQCPack: ** diff --git a/unitTests/src/makefile b/unitTests/src/makefile index ae42cfd2..a8346a95 100644 --- a/unitTests/src/makefile +++ b/unitTests/src/makefile @@ -12,7 +12,7 @@ RunF = pgfortran -i8 -r8 -Mallocatable=03 # # The 'all' rule. # -all: unitTest01.exe +all: unitTest01.exe unitTest02.exe # # Generic rules for building module (*.mod) and object (*.o) files. diff --git a/unitTests/src/unitTest02.f03 b/unitTests/src/unitTest02.f03 new file mode 100644 index 00000000..ca568439 --- /dev/null +++ b/unitTests/src/unitTest02.f03 @@ -0,0 +1,295 @@ + program unitTest02 +! +! This unit test validates character scalar and vector support in +! MQC_Variable, including intrinsic-like inquiry, assignment, ADJUSTL, +! ADJUSTR, LEN_TRIM, and scalar TRIM operations, printing, and +! String_Change_Case delegation to MQC_General. +! +! The internal assert* routines provide a lightweight, self-contained +! validation framework. Successful comparisons return normally; failed +! comparisons print the test label and available diagnostics, then use +! ERROR STOP 1 to terminate the program with a nonzero status. Reaching the +! final PASS message therefore means that every assertion succeeded. +! +! H. P. Hratchian, 2026. +! +! + use MQC_General + use MQC_Algebra2 + use iso_fortran_env,only:int64 + implicit none +! + type(MQC_Variable)::scalarVariable,vectorVariable,changedVariable + type(MQC_Variable)::elementVariable,reshapedVariable,clearedVariable + type(MQC_Variable)::adjustedVariable,lengthVariable,trimmedVariable + character(len=8),dimension(3)::vectorInput + character(len=8),dimension(3)::intrinsicCharacterVector + character(len=:),dimension(:),allocatable::vectorOutput + character(len=:),allocatable::trimmedOutput + character(len=8)::intrinsicCharacterScalar + character(len=8)::scalarOutput + character(len=256)::line + integer(kind=int64)::iOut + integer(kind=int64)::integerScalar + integer(kind=int64),dimension(:),allocatable::integerVector +! +! +! Character scalar assignment and intrinsic-like inquiries. +! + scalarVariable = 'Ab c9' + call assertCharacter('scalar type',TRIM(scalarVariable%getType()), & + 'CHARACTER') + call assertInteger('scalar rank',RANK(scalarVariable),0_int64) + call assertInteger('scalar size',SIZE(scalarVariable),1_int64) + call assertInteger('scalar length',LEN(scalarVariable),5_int64) + scalarOutput = scalarVariable + call assertCharacter('scalar round trip',scalarOutput,'Ab c9') + scalarOutput = 'MiXeD' + call String_Change_Case(scalarOutput,'L') + call assertCharacter('intrinsic string change case',scalarOutput, & + 'mixed') +! +! Both the generic and type-bound change-case entry points must delegate +! to the intrinsic-character implementation without changing element width. +! + call String_Change_Case(scalarVariable,'U',changedVariable) + scalarOutput = scalarVariable + call assertCharacter('change-case input retained',scalarOutput,'Ab c9') + scalarOutput = changedVariable + call assertCharacter('generic uppercase',scalarOutput,'AB C9') + call changedVariable%change_case('L') + scalarOutput = changedVariable + call assertCharacter('type-bound lowercase',scalarOutput,'ab c9') + call assertInteger('case preserves length',LEN(changedVariable),5_int64) + scalarVariable = 7_int64 + scalarVariable = 'ReTyped' + scalarOutput = scalarVariable + call assertCharacter('numeric to character reassignment',scalarOutput, & + 'ReTyped') +! +! Intrinsic-character kernels in MQC_General and the corresponding +! overloaded and type-bound MQC_Variable operations. +! + intrinsicCharacterScalar = ' Ab' + intrinsicCharacterVector = & + [ character(len=8)::' One',' Two','Three' ] +! + scalarOutput = mqc_adjustl(intrinsicCharacterScalar) + call assertCharacter('general scalar adjustl',scalarOutput,'Ab') + scalarOutput = mqc_adjustr(intrinsicCharacterScalar) + call assertCharacter('general scalar adjustr',scalarOutput,' Ab') + integerScalar = mqc_len_trim(intrinsicCharacterScalar) + call assertInteger('general scalar len_trim',integerScalar,4_int64) + trimmedOutput = mqc_trim(intrinsicCharacterScalar) + call assertCharacter('general scalar trim',trimmedOutput,' Ab') + call assertInteger('general scalar trim length', & + LEN(trimmedOutput),4_int64) +! + vectorOutput = mqc_adjustl(intrinsicCharacterVector) + call assertCharacterVector('general vector adjustl',vectorOutput, & + [ character(len=8)::'One','Two','Three' ]) + vectorOutput = mqc_adjustr(intrinsicCharacterVector) + call assertCharacterVector('general vector adjustr',vectorOutput, & + [ character(len=8)::' One',' Two',' Three' ]) + integerVector = mqc_len_trim(intrinsicCharacterVector) + call assertIntegerVector('general vector len_trim',integerVector, & + [5_int64,4_int64,5_int64]) +! + scalarVariable = intrinsicCharacterScalar + adjustedVariable = ADJUSTL(scalarVariable) + scalarOutput = adjustedVariable + call assertCharacter('overloaded scalar adjustl',scalarOutput,'Ab') + call assertInteger('adjustl preserves scalar length', & + LEN(adjustedVariable),8_int64) + adjustedVariable = scalarVariable%adjustr() + scalarOutput = adjustedVariable + call assertCharacter('type-bound scalar adjustr',scalarOutput, & + ' Ab') + lengthVariable = LEN_TRIM(scalarVariable) + integerScalar = lengthVariable + call assertInteger('overloaded scalar len_trim',integerScalar,4_int64) + trimmedVariable = scalarVariable%trim() + scalarOutput = trimmedVariable + call assertCharacter('type-bound scalar trim',scalarOutput,' Ab') + call assertInteger('trim changes scalar length', & + LEN(trimmedVariable),4_int64) +! + vectorVariable = intrinsicCharacterVector + adjustedVariable = vectorVariable%adjustl() + vectorOutput = adjustedVariable + call assertCharacterVector('type-bound vector adjustl',vectorOutput, & + [ character(len=8)::'One','Two','Three' ]) + adjustedVariable = ADJUSTR(vectorVariable) + vectorOutput = adjustedVariable + call assertCharacterVector('overloaded vector adjustr',vectorOutput, & + [ character(len=8)::' One',' Two',' Three' ]) + lengthVariable = vectorVariable%len_trim() + integerVector = [0_int64] + integerVector = lengthVariable + call assertIntegerVector('type-bound vector len_trim',integerVector, & + [5_int64,4_int64,5_int64]) +! +! Character vector assignment, extraction, insertion, reshape, and +! allocatable intrinsic assignment. +! + vectorInput = [ character(len=8)::'Alpha','bETA','Gamma' ] + vectorVariable = vectorInput + call assertInteger('vector rank',RANK(vectorVariable),1_int64) + call assertInteger('vector size',SIZE(vectorVariable),3_int64) + call assertInteger('vector dimension',SIZE(vectorVariable,1),3_int64) + call assertInteger('vector length',LEN(vectorVariable),8_int64) + vectorOutput = vectorVariable + call assertCharacterVector('vector round trip',vectorOutput,vectorInput) +! + call vectorVariable%put('Delta',[2_int64]) + elementVariable = vectorVariable%getVal([2_int64]) + scalarOutput = elementVariable + call assertCharacter('put and getVal',scalarOutput,'Delta') +! + reshapedVariable = RESHAPE(vectorVariable,[3_int64]) + vectorOutput = reshapedVariable + call assertCharacterVector('reshape preserves values',vectorOutput, & + [ character(len=8)::'Alpha','Delta','Gamma' ]) + changedVariable = MQC_Variable_mqc2mqc(vectorVariable) + vectorOutput = changedVariable + call assertCharacterVector('explicit MQC copy',vectorOutput, & + [ character(len=8)::'Alpha','Delta','Gamma' ]) +! +! Clear must retain the fixed element width across the new vector. +! + call clearedVariable%clear('MiXeD',[3_int64]) + call assertInteger('clear length',LEN(clearedVariable),5_int64) + call clearedVariable%change_case('U') + vectorOutput = clearedVariable + call assertCharacterVector('clear and change case',vectorOutput, & + [ character(len=5)::'MIXED','MIXED','MIXED' ]) +! +! The scalar MQC conversion and the character printing wrappers are also +! part of the public character pathway. +! + scalarVariable = MQC('Print Me') + scalarOutput = scalarVariable + call assertCharacter('mqc character conversion',scalarOutput,'Print Me') + open(newunit=iOut,status='scratch',action='readwrite',form='formatted') + call mqc_print_scalar('General',iOut,header='scalar') + call mqc_print_vector([ character(len=4)::'One','Two' ],iOut, & + header='vector') + rewind(iOut) + read(iOut,'(A)') line + call assertContains('general scalar print',line,'General') + read(iOut,'(A)') line + call assertContains('general vector print header',line,'vector') + read(iOut,'(A)') line + call assertContains('general vector print element',line,'One') + close(iOut) +! + open(newunit=iOut,status='scratch',action='readwrite',form='formatted') + call scalarVariable%print(iOut=iOut,header='scalar') + call vectorVariable%print(iOut=iOut,header='vector') + rewind(iOut) + read(iOut,'(A)') line + call assertContains('scalar print',line,'Print Me') + read(iOut,'(A)') line + call assertContains('vector print header',line,'vector') + read(iOut,'(A)') line + call assertContains('vector print element',line,'Alpha') + close(iOut) +! + write(*,'(1x,A)') 'unitTest02: PASS' +! + contains + +! +!PROCEDURE assertCharacter + subroutine assertCharacter(label,actual,expected) + implicit none + character(len=*),intent(in)::label,actual,expected +! + if(actual.ne.expected) then + write(*,'(1x,A)') 'FAIL: '//TRIM(label) + write(*,'(3x,A,A,A)') 'actual = <',actual,'>' + write(*,'(3x,A,A,A)') 'expected = <',expected,'>' + error stop 1 + endIf +! + return + end subroutine assertCharacter + + +! +!PROCEDURE assertCharacterVector + subroutine assertCharacterVector(label,actual,expected) + implicit none + character(len=*),intent(in)::label + character(len=*),dimension(:),intent(in)::actual,expected +! + if(SIZE(actual).ne.SIZE(expected)) then + write(*,'(1x,A)') 'FAIL: '//TRIM(label)//' size mismatch' + error stop 1 + endIf + if(ANY(actual.ne.expected)) then + write(*,'(1x,A)') 'FAIL: '//TRIM(label) + error stop 1 + endIf +! + return + end subroutine assertCharacterVector + + +! +!PROCEDURE assertContains + subroutine assertContains(label,actual,expectedSubstring) + implicit none + character(len=*),intent(in)::label,actual,expectedSubstring +! + if(INDEX(actual,expectedSubstring).eq.0) then + write(*,'(1x,A)') 'FAIL: '//TRIM(label) + write(*,'(3x,A,A,A)') 'line = <',TRIM(actual),'>' + error stop 1 + endIf +! + return + end subroutine assertContains + + +! +!PROCEDURE assertInteger + subroutine assertInteger(label,actual,expected) + implicit none + character(len=*),intent(in)::label + integer(kind=int64),intent(in)::actual,expected +! + if(actual.ne.expected) then + write(*,'(1x,A)') 'FAIL: '//TRIM(label) + write(*,'(3x,A,I0)') 'actual = ',actual + write(*,'(3x,A,I0)') 'expected = ',expected + error stop 1 + endIf +! + return + end subroutine assertInteger + + +! +!PROCEDURE assertIntegerVector + subroutine assertIntegerVector(label,actual,expected) + implicit none + character(len=*),intent(in)::label + integer(kind=int64),dimension(:),intent(in)::actual,expected +! + if(SIZE(actual).ne.SIZE(expected)) then + write(*,'(1x,A)') 'FAIL: '//TRIM(label)//' size mismatch' + error stop 1 + endIf + if(ANY(actual.ne.expected)) then + write(*,'(1x,A)') 'FAIL: '//TRIM(label) + write(*,'(3x,A,*(I0,1x))') 'actual = ',actual + write(*,'(3x,A,*(I0,1x))') 'expected = ',expected + error stop 1 + endIf +! + return + end subroutine assertIntegerVector + + + end program unitTest02