53 LOGICAL,
POINTER,
CONTIGUOUS :: &
54 mask1d(:) => null(), &
55 mask2d(:,:) => null(), &
56 mask3d(:,:,:) => null()
70 INTEGER :: rank = -1,dims(2) = 0
71 REAL,
POINTER,
CONTIGUOUS :: data1d(:) => null()
72 REAL,
POINTER,
CONTIGUOUS :: data2d(:,:) => null()
73 REAL,
POINTER,
CONTIGUOUS :: data3d(:,:,:) => null()
74 REAL,
POINTER,
CONTIGUOUS :: data4d(:,:,:,:) => null()
75 REAL,
POINTER,
CONTIGUOUS :: data5d(:,:,:,:,:) => null()
133 INTEGER,
OPTIONAL,
INTENT(IN) :: m,n
137 IF (new_ma%Init(m,n))
return
140 print *,
"ERROR in marray_base::CreateMArray: marray initialization failed"
146 FUNCTION init(this,m,n)
RESULT(success)
149 INTEGER,
OPTIONAL,
INTENT(IN) :: m,n
155 print *,
"DEBUG INFO in marray_base::Init: marray initialization"
165 print *,
"ERROR in marray_base::Init: 1st dimension of mesh array should be >= 0"
173 print *,
"ERROR in marray_base::Init: 2nd dimension of mesh array should be >= 0"
188 IF (.NOT.
ASSOCIATED(this%data1d))
THEN
190 print
'(A,I2,A,2(I4))',
" creating marray with rank ",this%RANK,
" and dimensions ",this%DIMS(1:2)
193 ALLOCATE(this%data1d(
inum*
jnum*
knum*this%DIMS(1)*this%DIMS(2)),stat=err)
196 print *,
"ERROR in marray_base::Init: memory allocation failed for data1d array"
201 print *,
"DEBUG INFO in marray_base::Init: memory allocated for data1d, size=",
SIZE(this%data1d)
206 IF (
SIZE(this%data1d).NE.
inum*
jnum*
knum*this%DIMS(1)*this%DIMS(2))
THEN
208 print *,
"ERROR in marray_base::Init: data1d array size mismatch"
214 IF (
SIZE(this%data1d).GT.0)
THEN
215 IF (.NOT.this%AssignPointers())
return
227 INTEGER,
INTENT(IN) :: igmin_,igmax_,jgmin_,jgmax_,kgmin_,kgmax_
262 print *,
"DEBUG INFO in marray_base::AssignPointers: assign 2d,3d,... pointers"
265 IF (.NOT.
ASSOCIATED(this%data1d))
return
267 IF (
SIZE(this%data1d).GT.0)
THEN
268 SELECT CASE(this%RANK)
275 this%data2d(1:
inum*
jnum*
knum,1:this%DIMS(1)) => this%data1d
280 this%data2d(1:
inum*
jnum*
knum*this%DIMS(1),1:this%DIMS(2)) => this%data1d
281 this%data3d(1:
inum*
jnum*
knum,1:this%DIMS(1),1:this%DIMS(2)) => this%data1d
286 print *,
"ERROR in marray_base::AssignPointers: rank must be in {0,1,2}"
305 REAL,
DIMENSION(IGMIN:,JGMIN:,KGMIN:),
TARGET :: array
307 REAL,
DIMENSION(:,:,:),
POINTER :: ptr
319 REAL,
DIMENSION(IGMIN:,JGMIN:,KGMIN:,:),
TARGET &
322 REAL,
DIMENSION(:,:,:,:),
POINTER :: ptr
334 REAL,
DIMENSION(IGMIN:,JGMIN:,KGMIN:,:,:),
TARGET &
337 REAL,
DIMENSION(:,:,:,:,:),
POINTER :: ptr
351#if !defined(__GFORTRAN__) || (defined(__GFORTRAN__) && __GNUC__ >= 13)
354 LOGICAL :: LHS_initialized
357 print *,
"DEBUG INFO in marray_base::AssignMArray_0: marray assignment"
359 IF (.NOT.
ASSOCIATED(ma%data1d).OR.ma%rank.LT.0)
THEN
361 print *,
"ERROR in marray_base::AssignMArray_0: rhs of assignment not initialized"
368 this%DIMS(:) = ma%DIMS(:)
370 lhs_initialized =
ASSOCIATED(this%data1d)
379#if !defined(__GFORTRAN__) || (defined(__GFORTRAN__) && __GNUC__ > 12)
381 IF (.NOT.lhs_initialized)
THEN
382 ALLOCATE(this%data1d,source=ma%data1d,stat=err)
385 print *,
"ERROR in marray_base::AssignMArray_0: marray initialization failed"
390 print *,
"DEBUG INFO in marray_base::AssignMArray_0: memory allocated for data1d, size=",
SIZE(this%data1d)
396 IF (lhs_initialized)
THEN
398 IF (.NOT.(this.match.ma))
THEN
400 print *,
"ERROR in marray_base::AssignMArray_0: shape mismatch"
404 IF (
SIZE(this%data1d).NE.
SIZE(ma%data1d))
THEN
406 print *,
"ERROR in marray_base::AssignMArray_0: size mismatch"
411 this%data1d(:) = ma%data1d(:)
416 this%data1d => ma%data1d
420 IF (.NOT.lhs_initialized)
THEN
430 IF (.NOT.this%AssignPointers())
THEN
432 print *,
"ERROR in marray_base::AssignMArray_0: pointer reassignment failed"
446 REAL,
DIMENSION(:),
INTENT(IN) :: a
449 print *,
"DEBUG INFO in marray_base::AssignMArray_1: assigning 1D Fortran array"
452 IF (
SIZE(this%data1d).NE.
SIZE(a))
THEN
453 print *,
"ERROR in marray_base::AssignMArray_1: size mismatch ",
SIZE(this%data1d),
" != ",
SIZE(a)
457 this%data1d(:) = a(:)
468 REAL,
DIMENSION(:,:),
INTENT(IN) :: a
471 print *,
"DEBUG INFO in marray_base::AssignMArray_2: assigning 2D Fortran array"
474 IF (.NOT.all(shape(this%data2d).EQ.shape(a)))
THEN
475 print *,
"ERROR in marray_base::AssignMArray_2: shape mismatch"
479 this%data2d(:,:) = a(:,:)
490 REAL,
DIMENSION(:,:,:),
INTENT(IN) :: a
493 print *,
"DEBUG INFO in marray_base::AssignMArray_3: assigning 3D Fortran array"
496 IF (.NOT.all(shape(this%data3d).EQ.shape(a)))
THEN
497 print *,
"ERROR in marray_base::AssignMArray_3: shape mismatch"
501 this%data3d(:,:,:) = a(:,:,:)
512 REAL,
DIMENSION(:,:,:,:),
INTENT(IN) :: a
515 print *,
"DEBUG INFO in marray_base::AssignMArray_4: assigning 4D Fortran array"
518 IF (.NOT.all(shape(this%data4d).EQ.shape(a)))
THEN
519 print *,
"ERROR in marray_base::AssignMArray_4: shape mismatch"
523 this%data4d(:,:,:,:) = a(:,:,:,:)
534 REAL,
DIMENSION(:,:,:,:,:),
INTENT(IN) :: a
537 print *,
"DEBUG INFO in marray_base::AssignMArray_5: assigning 5D Fortran array"
540 IF (.NOT.all(shape(this%data5d).EQ.shape(a)))
THEN
541 print *,
"ERROR in marray_base::AssignMArray_5: shape mismatch"
545 this%data5d(:,:,:,:,:) = a(:,:,:,:,:)
555 res = (this%rank.EQ.that%rank).AND.all(this%dims(:).EQ.that%dims(:))
566 REAL,
DIMENSION(SIZE(this%data1d)) :: data1d
569 print *,
"DEBUG INFO in marray_base::AddMArray_0: adding 2 marrays"
572 IF (.NOT.
ASSOCIATED(this%data1d))
THEN
573 print *,
"ERROR in marray_base::AddMArray_0: 1nd argument not initialized"
576 IF (.NOT.
ASSOCIATED(that%data1d))
THEN
577 print *,
"ERROR in marray_base::AddMArray_0: 2nd argument not initialized"
580 IF (.NOT.(this.match.that))
THEN
581 print *,
"ERROR in marray_base::AddMArray_0: shape mismatch"
585 data1d(:) = this%data1d(:) + that%data1d(:)
596 REAL,
DIMENSION(:),
INTENT(IN) :: a
597 REAL,
DIMENSION(SIZE(this%data1d)) :: b
600 print *,
"DEBUG INFO in marray_base::AddMArray_1: adding marray to 1d Fortran array"
603 IF (
SIZE(this%data1d).NE.
SIZE(a))
THEN
604 print *,
"ERROR in marray_base::AddMArray_1: size mismatch"
608 b(:) = this%data1d(:) + a(:)
619 REAL,
DIMENSION(SIZE(this%data2d,1),SIZE(this%data2d,2)),
INTENT(IN) :: a
620 REAL,
DIMENSION(SIZE(this%data2d,1),SIZE(this%data2d,2)) :: b
623 print *,
"DEBUG INFO in marray_base::AddMArray_2: adding marray to 2d Fortran array"
626 IF (.NOT.all(shape(this%data2d).EQ.shape(a)))
THEN
627 print *,
"ERROR in marray_base::AddMArray_2: shape mismatch"
631 b(:,:) = this%data2d(:,:) + a(:,:)
642 REAL,
DIMENSION(:,:,:),
INTENT(IN) :: a
643 REAL,
DIMENSION(SIZE(this%data3d,1),SIZE(this%data3d,2),SIZE(this%data3d,3)) :: b
646 print *,
"DEBUG INFO in marray_base::AddMArray_3: adding marray to 3d Fortran array"
649 IF (.NOT.all(shape(this%data3d).EQ.shape(a)))
THEN
650 print *,
"ERROR in marray_base::AddMArray_3: shape mismatch"
654 b(:,:,:) = this%data3d(:,:,:) + a(:,:,:)
665 REAL,
DIMENSION(:,:,:,:),
INTENT(IN) :: a
666 REAL,
DIMENSION(SIZE(this%data4d,1),SIZE(this%data4d,2),SIZE(this%data4d,3), &
SIZE(this%data4d,4)) :: b
669 print *,
"DEBUG INFO in marray_base::AddMArray_4: adding marray to 4d Fortran array"
672 IF (.NOT.all(shape(this%data4d).EQ.shape(a)))
THEN
673 print *,
"ERROR in marray_base::AddMArray_4: shape mismatch"
677 b(:,:,:,:) = this%data4d(:,:,:,:) + a(:,:,:,:)
688 REAL,
DIMENSION(:,:,:,:,:),
INTENT(IN) :: a
689 REAL,
DIMENSION(SIZE(this%data5d,1),SIZE(this%data5d,2),SIZE(this%data5d,3), &
SIZE(this%data5d,4),SIZE(this%data5d,5)) :: b
692 print *,
"DEBUG INFO in marray_base::AddMArray_5: adding marray to 5d Fortran array"
695 IF (.NOT.all(shape(this%data5d).EQ.shape(a)))
THEN
696 print *,
"ERROR in marray_base::AddMArray_5: shape mismatch"
700 b(:,:,:,:,:) = this%data5d(:,:,:,:,:) + a(:,:,:,:,:)
712 REAL,
DIMENSION(SIZE(this%data1d)) :: data1d
715 print *,
"DEBUG INFO in marray_base::MultMArray_0: multiply 2 marrays"
718 IF (.NOT.
ASSOCIATED(this%data1d))
THEN
719 print *,
"ERROR in marray_base::MultMArray_0: 1nd argument not initialized"
721 IF (.NOT.
ASSOCIATED(that%data1d))
THEN
722 print *,
"ERROR in marray_base::MultMArray_0: 2nd argument not initialized"
724 IF (.NOT.(this.match.that))
THEN
725 print *,
"ERROR in marray_base::MultMArray_0: shape mismatch"
728 data1d(:) = this%data1d(:) * that%data1d(:)
739 REAL,
DIMENSION(:),
INTENT(IN) :: a
740 REAL,
DIMENSION(SIZE(this%data1d)) :: b
743 print *,
"DEBUG INFO in marray_base::MultMArray_1: multiply marray with 1d Fortran array"
746 IF (
SIZE(this%data1d).NE.
SIZE(a))
THEN
747 print *,
"ERROR in marray_base::MultMArray_1: size mismatch"
751 b(:) = this%data1d(:) * a(:)
762 REAL,
DIMENSION(:,:),
INTENT(IN) :: a
763 REAL,
DIMENSION(SIZE(this%data2d,1),SIZE(this%data2d,2)) :: b
766 print *,
"DEBUG INFO in marray_base::MultMArray_2: multiply marray with 2d Fortran array"
769 IF (.NOT.all(shape(this%data2d).EQ.shape(a)))
THEN
770 print *,
"ERROR in marray_base::MultMArray_2: shape mismatch"
774 b(:,:) = this%data2d(:,:) * a(:,:)
785 REAL,
DIMENSION(:,:,:),
INTENT(IN) :: a
786 REAL,
DIMENSION(SIZE(this%data3d,1),SIZE(this%data3d,2),SIZE(this%data3d,3)) :: b
789 print *,
"DEBUG INFO in marray_base::MultMArray_3: multiply marray with 3d Fortran array"
792 IF (.NOT.all(shape(this%data3d).EQ.shape(a)))
THEN
793 print *,
"ERROR in marray_base::MultMArray_3: shape mismatch"
797 b(:,:,:) = this%data3d(:,:,:) * a(:,:,:)
808 REAL,
DIMENSION(:,:,:,:),
INTENT(IN) :: a
809 REAL,
DIMENSION(SIZE(this%data4d,1),SIZE(this%data4d,2),SIZE(this%data4d,3), &
SIZE(this%data4d,4)) :: b
812 print *,
"DEBUG INFO in marray_base::MultMArray_4: multiply marray with 4d Fortran array"
815 IF (.NOT.all(shape(this%data4d).EQ.shape(a)))
THEN
816 print *,
"ERROR in marray_base::MultMArray_4: shape mismatch"
820 b(:,:,:,:) = this%data4d(:,:,:,:) * a(:,:,:,:)
831 REAL,
DIMENSION(:,:,:,:,:),
INTENT(IN) :: a
832 REAL,
DIMENSION(SIZE(this%data5d,1),SIZE(this%data5d,2),SIZE(this%data5d,3), &
SIZE(this%data5d,4),SIZE(this%data5d,5)) :: b
835 print *,
"DEBUG INFO in marray_base::MultMArray_5: multiply marray with 5d Fortran array"
838 IF (.NOT.all(shape(this%data5d).EQ.shape(a)))
THEN
839 print *,
"ERROR in marray_base::MultMArray_5: shape mismatch"
843 b(:,:,:,:,:) = this%data5d(:,:,:,:,:) * a(:,:,:,:,:)
855 REAL,
DIMENSION(SIZE(this%data2d,DIM=1),3) :: data2d
858 print *,
"DEBUG INFO in marray_base::CrossProduct_0: compute cross product of two 3D vector like marrays"
861 IF (.NOT.
ASSOCIATED(this%data1d))
THEN
862 print *,
"ERROR in marray_base::CrossProduct_0: 1nd argument not initialized"
864 IF (.NOT.
ASSOCIATED(that%data1d))
THEN
865 print *,
"ERROR in marray_base::CrossProduct_0: 2nd argument not initialized"
868 IF (.NOT.(this.match.that))
THEN
870 print *,
"ERROR in marray_base::CrossProduct_0: shape mismatch"
874 IF (this%DIMS(this%RANK).NE.3)
THEN
876 print *,
"ERROR in marray_base::CrossProduct_0: not a 3D vector"
880 data2d(:,1) =
axb1(this%data2d(:,2),this%data2d(:,3),that%data2d(:,2),that%data2d(:,3))
881 data2d(:,2) =
axb1(this%data2d(:,3),this%data2d(:,1),that%data2d(:,3),that%data2d(:,1))
882 data2d(:,3) =
axb1(this%data2d(:,1),this%data2d(:,2),that%data2d(:,1),that%data2d(:,2))
885 ELEMENTAL FUNCTION axb1(a2,a3,b2,b3)
888 REAL,
INTENT(IN) :: a2,a3,b2,b3
897 SUBROUTINE destroy(this,called_from_finalize)
901 LOGICAL,
OPTIONAL :: called_from_finalize
904 WRITE(*,
'(A)',advance=
'NO')
" DEBUG INFO in marray_base::Destroy called"
905 IF (
PRESENT(called_from_finalize))
THEN
906 IF (called_from_finalize)
WRITE(*,
'(A)')
" from Finalize"
909 IF (
ASSOCIATED(this%data1d))
THEN
911 print *,
"DEBUG INFO in marray_base::Destroy: deallocating data1d, size=",
SIZE(this%data1d)
913 DEALLOCATE(this%data1d)
915 NULLIFY(this%data1d,this%data2d,this%data3d,this%data4d,this%data5d)
926 print *,
"DEBUG INFO in marray_base::Finalize called"
928 CALL this%Destroy(.true.)
935 INTEGER,
OPTIONAL :: idx(6)
939 IF (new_sel%Init(idx))
return
941 print *,
"ERROR in selection_base::CreateSelection: initialization failed"
950 INTEGER,
OPTIONAL :: idx(6)
956 print *,
"DEBUG INFO in marray_base::Init_selection: selection initialization"
964 print *,
"ERROR in marray_base::Init_selection: memory allocation failed"
971 IF (
PRESENT(idx))
THEN
972 CALL this%Cuboid(idx(1),idx(2),idx(3),idx(4),idx(5),idx(6))
974 CALL this%Everything()
988 print *,
"DEBUG INFO in marray_base::AssignSelection: selection assignment"
990 IF (.NOT.
ASSOCIATED(sel%mask1d))
THEN
992 print *,
"ERROR in marray_base::AssignSelection: rhs of assignment not initialized"
997 IF (.NOT.
ASSOCIATED(this%mask1d))
THEN
1005#if defined(__GFORTRAN__) && __GNUC__ < 13
1006 this%imin = sel%imin
1007 this%imax = sel%imax
1008 this%jmin = sel%jmin
1009 this%jmax = sel%jmax
1010 this%kmin = sel%kmin
1011 this%kmax = sel%kmax
1012 this%mask1d => sel%mask1d
1019 IF (.NOT.this%Init((/sel%imin,sel%imax,sel%jmin,sel%jmax,sel%kmin,sel%kmax/)))
THEN
1021 print *,
"ERROR in marray_base::AssignSelection: initialization failed"
1027 this%imin = sel%imin
1028 this%imax = sel%imax
1029 this%jmin = sel%jmin
1030 this%jmax = sel%jmax
1031 this%kmin = sel%kmin
1032 this%kmax = sel%kmax
1034 IF (.NOT.
SIZE(this%mask1d).EQ.
SIZE(sel%mask1d))
THEN
1036 print *,
"ERROR in marray_base::AssignSelection: size mismatch"
1041 this%mask1d(:) = sel%mask1d(:)
1044 SUBROUTINE cuboid(this,imin,imax,jmin,jmax,kmin,kmax)
1048 INTEGER,
INTENT(IN) :: imin,imax,jmin,jmax,kmin,kmax
1061 IF ((i.GE.this%imin.AND.i.LE.this%imax).AND. &
1062 (j.GE.this%jmin.AND.j.LE.this%jmax).AND. &
1063 (k.GE.this%kmin.AND.k.LE.this%kmax))
THEN
1064 this%mask3d(i,j,k) = .true.
1066 this%mask3d(i,j,k) = .false.
1084 this%mask1d(:) = .true.
1093 IF (
ASSOCIATED(this%mask1d))
DEALLOCATE(this%mask1d)
1094 NULLIFY(this%mask2d,this%mask3d)
1103 CALL this%Destroy_selection()
elemental real function axb1(a2, a3, b2, b3)
base class for mesh arrays
type(selection_base) function createselection(idx)
subroutine destructor_selection(this)
actual destructor of selection_base
subroutine assignmarray_3(this, a)
assign 3D fortran array to mesh array
subroutine cuboid(this, imin, imax, jmin, jmax, kmin, kmax)
real function, dimension(size(this%data2d, 1), size(this%data2d, 2)) addmarray_2(this, a)
add 2D fortran array and mesh array
type(marray_base) function createmarray(m, n)
constructor for mesh arrays
real function, dimension(size(this%data1d)) multmarray_1(this, a)
multiply 1D fortran array and mesh arrays
subroutine, public closemeshproperties
unsets global mesh properties
real function, dimension(size(this%data4d, 1), size(this%data4d, 2), size(this%data4d, 3), size(this%data4d, 4)) addmarray_4(this, a)
add 4D fortran array and mesh array
subroutine assignmarray_5(this, a)
assign 5D fortran array to mesh array
logical function assignpointers(this)
assign pointers of different shapes to the 1D data
real function, dimension(size(this%data1d)) addmarray_0(this, that)
add 2 mesh arrays
integer, save knum
array sizes
logical, save idx_init
init status
real function, dimension(:,:,:,:), pointer remapbounds_1(this, array)
remap lower bounds in the first 3 dimensions of rank 1 mesh arrays
subroutine assignselection(this, sel)
assigns one selection to another selection
real function, dimension(:,:,:), pointer remapbounds_0(this, array)
remap lower bounds in the first 3 dimensions of rank 0 mesh arrays
subroutine, public initmeshproperties(igmin_, igmax_, jgmin_, jgmax_, kgmin_, kgmax_)
sets global mesh properties
real function, dimension(size(this%data5d, 1), size(this%data5d, 2), size(this%data5d, 3), size(this%data5d, 4), size(this%data5d, 5)) addmarray_5(this, a)
add 5D fortran array and mesh array
real function, dimension(size(this%data1d)) addmarray_1(this, a)
add 1D fortran array and mesh array
real function, dimension(size(this%data2d, 1), size(this%data2d, 2)) multmarray_2(this, a)
multiply 2D fortran array and mesh arrays
subroutine assignmarray_4(this, a)
assign 4D fortran array to mesh array
real function, dimension(size(this%data3d, 1), size(this%data3d, 2), size(this%data3d, 3)) addmarray_3(this, a)
add 3D fortran array and mesh array
integer, save igmax
1st dim
real function, dimension(size(this%data4d, 1), size(this%data4d, 2), size(this%data4d, 3), size(this%data4d, 4)) multmarray_4(this, a)
multiply 4D fortran array and mesh arrays
real function, dimension(size(this%data1d)) multmarray_0(this, that)
multiply 2 mesh arrays
logical function init(this, m, n)
basic initialization of mesh array class
subroutine finalize(this)
real function, dimension(size(this%data5d, 1), size(this%data5d, 2), size(this%data5d, 3), size(this%data5d, 4), size(this%data5d, 5)) multmarray_5(this, a)
multiply 5D fortran array and mesh arrays
real function, dimension(size(this%data3d, 1), size(this%data3d, 2), size(this%data3d, 3)) multmarray_3(this, a)
multiply 3D fortran array and mesh arrays
integer, save jgmax
2nd dim
subroutine destroy_selection(this)
destructor of all selection classes
subroutine everything(this)
real function, dimension(:,:,:,:,:), pointer remapbounds_2(this, array)
remap lower bounds in the first 3 dimensions of rank 2 mesh arrays
logical function init_selection(this, idx)
basic initialization of selection
pure logical function shapesmatch(this, that)
integer, save kgmax
3rd dim
subroutine assignmarray_2(this, a)
assign 2D fortran array to mesh array
subroutine assignmarray_0(this, ma)
assigns one mesh array to another mesh array
subroutine destroy(this, called_from_finalize)
basic destructor of mesh arrays - this is called automatically if deallocate is invoked
real function, dimension(size(this%data2d, dim=1), 3) crossproduct_0(this, that)
compute outer (vector) product of 2 marrays works only, if last dimension has size 3!
subroutine assignmarray_1(this, a)
assign 1D fortran array to mesh array
type for selecting parts of an marray