Compiler Explorer

Source code

module subs
use iso_fortran_env
implicit none

integer, parameter :: ip = int8

! Parameters characterizing voxel meshing
    integer(ip), parameter :: CELL_MAXNUMFACES = 6_ip
    integer(ip), parameter :: ISOSURF_FACE_ERROR      =  127_ip    ! Invalid face
    integer(ip), parameter :: ISOSURF_FACE_INTERIOR   = -127_ip    ! Face in the cell's interior
    integer(ip), parameter :: ISOSURF_FACE_ISO        = -126_ip    ! Isosurface face
    integer(ip), parameter :: ISOSURF_FACE_VOLHI      = -125_ip    ! Face of high-volume wrapping
    integer(ip), parameter :: ISOSURF_FACE_FULLPARENT = -124_ip    ! Face fully overlaps with the parent one
    integer(ip), parameter :: ISOSURF_FACE_PARTPARENT = -123_ip    ! Face partially overlaps with the parent one
    integer(ip), parameter :: ISOSURF_FACE_MIN_ID     = -122_ip

contains

elemental integer(1) function CREATE_CODE(iface,ichild)
        integer(1), intent(in) :: iface   ! in [1:6] range
        integer(1), intent(in) :: ichild  ! in [1:32] range

integer(1), parameter :: CELL_MAXFACES1 = int(CELL_MAXNUMFACES,1)

CREATE_CODE = ISOSURF_FACE_MIN_ID + CELL_MAXNUMFACES*(ichild+1_ip) + iface 
    end function CREATE_CODE

elemental subroutine UNROLL_CODE(faceID,ifacecell,ichild,facetype)
        integer(ip), intent(in)  :: faceID
        integer(ip), intent(out) :: ifacecell,ichild
        integer(ip), intent(out) :: facetype

integer(ip), parameter :: ISOSURF_FACE_MIN_ID = -122_ip
        integer(ip), parameter :: CELL_MAXFACES1 = int(CELL_MAXNUMFACES,1)
        integer(ip) :: ichildp1

select case (faceID)
           case (ISOSURF_FACE_ERROR)
              facetype  = ISOSURF_FACE_ERROR
              ifacecell = -huge(ifacecell)
              ichild    = -huge(ichild)
           case (ISOSURF_FACE_ISO)
              facetype  = ISOSURF_FACE_ISO
              ifacecell = -huge(ifacecell)
              ichild    = -huge(ichild)
           case (ISOSURF_FACE_VOLHI)
              facetype  = ISOSURF_FACE_VOLHI
              ifacecell = -huge(ifacecell)
              ichild    = -huge(ichild)
           case (ISOSURF_FACE_MIN_ID+1_ip:82_ip)

ifacecell = faceID
              ichild    = -1_ip

! Child ID loop
              do while (ifacecell>ISOSURF_FACE_MIN_ID+CELL_MAXNUMFACES)
                 ichild     = ichild   +1_ip
                 ifacecell  = ifacecell-CELL_MAXNUMFACES
              end do

ifacecell = ifacecell-ISOSURF_FACE_MIN_ID

! Remainder = ifacecell
              select case (ichild)
                 case (-1_ip)
                    facetype = ISOSURF_FACE_PARTPARENT
                 case (0_ip)
                    facetype = ISOSURF_FACE_FULLPARENT
                 case default
                    facetype = ISOSURF_FACE_INTERIOR
              end select

case default
              facetype  = ISOSURF_FACE_ERROR
              ifacecell = -huge(ifacecell)
              ichild    = -huge(ichild)
        end select

end subroutine UNROLL_CODE
end module

program test_int1
  use subs

integer(ip) :: ichild,faceID,ichild_chk,iface_chk,facetype,iface_test,ichild_test
  logical :: iface_OK,child_OK,type_OK,success,code_OK

iface_test  = 1_ip
  ichild_test = 32_ip
  
  faceID = CREATE_CODE(iface_test,ichild_test)
  
  code_OK = faceID==77_ip

if (.not.code_OK) print *, ' code not OK: faceID=',faceID,' should be ',77_ip

call UNROLL_CODE(faceID,iface_chk,ichild_chk,facetype)

! Check expected results
  iface_OK = iface_chk==iface_test
  child_OK = ichild_chk==ichild_test
  type_OK  = facetype==ISOSURF_FACE_INTERIOR 
  success  = iface_OK.and.child_OK.and.type_OK

print *, merge('SUCCESS!','ERROR   ',success)

if (.not.success) print *, ' iface=',iface,&
                             ' faceID=',faceID,&
                             ' ifaceOK=',iface_chk,&
                             ' ichild_OK=',ichild_chk,&
                             ' facetype=',facetype

end program test_int1