Extracted random subroutine from CMISS/cm tree

part-of-field_routines.f90

  !================================================================================================================================
  !

  !>Initialises the interpolated point metrics for an interpolated point.
  SUBROUTINE FIELD_INTERPOLATED_POINT_METRICS_INITIALISE(INTERPOLATED_POINT,INTERPOLATED_POINT_METRICS,ERR,ERROR,*)

    !Argument variables
    TYPE(FIELD_INTERPOLATED_POINT_TYPE), POINTER :: INTERPOLATED_POINT !A pointer to the interpolated point to initliase the interpolated point metrics for
    TYPE(FIELD_INTERPOLATED_POINT_METRICS_TYPE), POINTER :: INTERPOLATED_POINT_METRICS !<On exit, a pointer to the interpolated point metrics that have been initialised
    INTEGER(INTG), INTENT(OUT) :: ERR !<The error code
    TYPE(VARYING_STRING), INTENT(OUT) :: ERROR !<The error string
    !Local Variables
    INTEGER(INTG) :: NUMBER_OF_XI_DIMENSIONS,NUMBER_OF_X_DIMENSIONS
    INTEGER(INTG) :: DUMMY_ERR
    TYPE(COORDINATE_SYSTEM_TYPE), POINTER :: COORDINATE_SYSTEM
    TYPE(VARYING_STRING) :: DUMMY_ERROR,LOCAL_ERROR

    CALL ENTERS("FIELD_INTERPOLATED_POINT_METRICS_INITIALISE",ERR,ERROR,*999)

    IF(ASSOCIATED(INTERPOLATED_POINT)) THEN
      IF(ASSOCIATED(INTERPOLATED_POINT_METRICS)) THEN
        CALL FLAG_ERROR("Interpolated point metrics is already associated.",ERR,ERROR,*998)
      ELSE
        NULLIFY(COORDINATE_SYSTEM)
        CALL FIELD_COORDINATE_SYSTEM_GET(INTERPOLATED_POINT%INTERPOLATION_PARAMETERS%FIELD,COORDINATE_SYSTEM,ERR,ERROR,*999)
        NUMBER_OF_X_DIMENSIONS=COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS
        NUMBER_OF_XI_DIMENSIONS=INTERPOLATED_POINT%INTERPOLATION_PARAMETERS%FIELD%DECOMPOSITION%MESH%NUMBER_OF_DIMENSIONS
        IF(NUMBER_OF_X_DIMENSIONS==SIZE(INTERPOLATED_POINT%VALUES,1)) THEN
          ALLOCATE(INTERPOLATED_POINT_METRICS,STAT=ERR)
          IF(ERR/=0) CALL FLAG_ERROR("Could not allocate interpolated point metrics.",ERR,ERROR,*999)
          ALLOCATE(INTERPOLATED_POINT_METRICS%GL(NUMBER_OF_XI_DIMENSIONS,NUMBER_OF_XI_DIMENSIONS),STAT=ERR)
          IF(ERR/=0) CALL FLAG_ERROR("Could not allocate interpolated point metrics convariant tensor.",ERR,ERROR,*999)
          ALLOCATE(INTERPOLATED_POINT_METRICS%GU(NUMBER_OF_XI_DIMENSIONS,NUMBER_OF_XI_DIMENSIONS),STAT=ERR)
          IF(ERR/=0) CALL FLAG_ERROR("Could not allocate interpolated point metrics contravariant tensor.",ERR,ERROR,*999)
          ALLOCATE(INTERPOLATED_POINT_METRICS%DX_DXI(NUMBER_OF_X_DIMENSIONS,NUMBER_OF_XI_DIMENSIONS),STAT=ERR)
          IF(ERR/=0) CALL FLAG_ERROR("Could not allocate interpolated point metrics dX_dXi.",ERR,ERROR,*999)
          ALLOCATE(INTERPOLATED_POINT_METRICS%DXI_DX(NUMBER_OF_XI_DIMENSIONS,NUMBER_OF_X_DIMENSIONS),STAT=ERR)
          IF(ERR/=0) CALL FLAG_ERROR("Could not allocate interpolated point metrics dXi_dX.",ERR,ERROR,*999)
          INTERPOLATED_POINT_METRICS%INTERPOLATED_POINT=>INTERPOLATED_POINT
          INTERPOLATED_POINT_METRICS%NUMBER_OF_X_DIMENSIONS=NUMBER_OF_X_DIMENSIONS
          INTERPOLATED_POINT_METRICS%NUMBER_OF_XI_DIMENSIONS=NUMBER_OF_XI_DIMENSIONS
          INTERPOLATED_POINT_METRICS%GL=0.0_DP
          INTERPOLATED_POINT_METRICS%GU=0.0_DP
          INTERPOLATED_POINT_METRICS%DX_DXI=0.0_DP
          INTERPOLATED_POINT_METRICS%DXI_DX=0.0_DP
          INTERPOLATED_POINT_METRICS%JACOBIAN=0.0_DP
          INTERPOLATED_POINT_METRICS%JACOBIAN_TYPE=0
        ELSE
          LOCAL_ERROR="The number of coordinate dimensions ("//TRIM(NUMBER_TO_VSTRING(NUMBER_OF_X_DIMENSIONS,"*",ERR,ERROR))// &
            & ") does not match the number of components of the interpolated point ("// &
            & TRIM(NUMBER_TO_VSTRING(SIZE(INTERPOLATED_POINT%VALUES,1),"*",ERR,ERROR))//")."
          CALL FLAG_ERROR(LOCAL_ERROR,ERR,ERROR,*998)
        ENDIF
      ENDIF
    ELSE
      CALL FLAG_ERROR("Interpolation point is not associated.",ERR,ERROR,*998)
    ENDIF

    CALL EXITS("FIELD_INTERPOLATED_POINT_METRICS_INITIALISE")
    RETURN
999 CALL FIELD_INTERPOLATED_POINT_METRICS_FINALISE(INTERPOLATED_POINT_METRICS,DUMMY_ERR,DUMMY_ERROR,*998)
998 CALL ERRORS("FIELD_INTERPOLATED_POINT_METRICS_INITIALISE",ERR,ERROR)
    CALL EXITS("FIELD_INTERPOLATED_POINT_METRICS_INITIALISE")
    RETURN 1
  END SUBROUTINE FIELD_INTERPOLATED_POINT_METRICS_INITIALISE